f2cl5.l 177 KB
Newer Older
1
; -*- Mode: lisp; package: F2CL -*-
rtoy's avatar
rtoy committed
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
; f2cl5.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;functions:
; declaration insertion
;      check_new_vbles
;      insert-declarations
;      make-initialisation
;      make-declaration
;      make-char-decl
;      make-char-init
;      get-implicit-type
;      get_array_type
;      default-int-p
;      vble-is-array-p
;      sym-is-fun-name
;      make-special-proclamation
;      make-special-var-decl
22
;      check-reserved-lisp-names
rtoy's avatar
rtoy committed
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
; structured stmt fix
;      fix-structure
;      fix-ifthen
;      end-do-p
;      label-matches-dolabel-p
;      fix-do
;      fix-tagbodies
;      remove-prefix 
;      multiple-do-labelp
; FORMAT parsing
;      parse-format
;      parse-format1
;      parse-write
;      parse-format-descriptor-list
;      fixnum-string
;      parse-format-descriptor-I
;      parse-format-descriptor-F
;      parse-format-descriptor-E
;      parse-format-descriptor-G
;      parse-format-descriptor-/
;      parse-format-descriptor-TR
;      parse-format-descriptor-X
;      parse-format-descriptor-S
;      parse-default-format-descriptor
;      fix-slashes

rtoy's avatar
rtoy committed
49
;;-----------------------------------------------------------------------------
rtoy's avatar
rtoy committed
50
(in-package :f2cl)
rtoy's avatar
rtoy committed
51

52
(defparameter *f2cl5-version*
53
  "$Id: f2cl5.l,v 505dc31bee3e 2013/03/26 03:32:16 toy $")
54

rtoy's avatar
rtoy committed
55
;; functions for setting up varaible declarations and initialisations
rtoy's avatar
rtoy committed
56
(eval-when (compile load eval)
57
  (proclaim '(special *intrinsic-function-names* *external-function-names*
rtoy's avatar
rtoy committed
58
59
60
	      *declared_vbles* *undeclared_vbles* *key_params* *save_vbles*
	      *explicit_vble_decls* *implicit_vble_decls* *common_array_dims*
	      *subprog_common_vars* *program-flag* 
61
	      *subprog-stmt-fns* *subprog_stmt_fns_bodies*
rtoy's avatar
rtoy committed
62
63
	      *auto-save-data*
	      *functions-used*
rtoy's avatar
rtoy committed
64
65
66
67
	      *vble-declaration-done*))
)

(defvar *fortran-keywords*
rtoy's avatar
rtoy committed
68
69
70
  '(assign if then go to goto call continue do fdo else elseif return
    stop print read write backspace close endfile inquire
    open rewind format and or not))
rtoy's avatar
rtoy committed
71

rtoy's avatar
rtoy committed
72

rtoy's avatar
rtoy committed
73

rtoy's avatar
rtoy committed
74
(defun check_new_vbles (exprs)
rtoy's avatar
rtoy committed
75
76
77
78
  (cond ((or (null exprs)
	     (numberp exprs)
	     (typep exprs 'string))
	 nil)
rtoy's avatar
rtoy committed
79
	((symbolp exprs)
rtoy's avatar
rtoy committed
80
	 (cond ((or (member exprs '(\, \' + - * / ** // ^ = equal > < >= <= >< |:|
81
				    /=
rtoy's avatar
rtoy committed
82
				    f2cl-// 
rtoy's avatar
rtoy committed
83
84
				    %false% %true%
				    funcall))
rtoy's avatar
rtoy committed
85
86
		    (member exprs *fortran-keywords*)
		    (member exprs *key_params* :key #'car)
87
		    (member exprs *external-function-names*)
rtoy's avatar
rtoy committed
88
89
		    (member exprs *declared_vbles*)
		    (member exprs *undeclared_vbles*)
rtoy's avatar
rtoy committed
90
91
		    (sym-is-fun-name (list exprs))
		    (sym-is-number-p exprs))
rtoy's avatar
rtoy committed
92
93
94
		;; This aren't new variables either because they can't
		;; be Fortran variables names or we've seen them
		;; already somewhere.
rtoy's avatar
rtoy committed
95
		nil)
rtoy's avatar
rtoy committed
96
	       ((eq exprs 'pause)
rtoy's avatar
rtoy committed
97
98
		)
	       (t
99
		(pushnew (check-reserved-lisp-names exprs) *undeclared_vbles*))))
rtoy's avatar
rtoy committed
100
	((listp exprs)
101
102
103
104
	 (cond ((eq (first exprs) 'multiple-value-bind)
		;; Function calls get turned into a MULTIPLE-VALUE-BIND, so
		;; the only possible place for variables is the arg list for
		;; the function.
105
		(mapc #'check_new_vbles (cdr (third exprs))))
106
107
108
109
110
	       ((eq (first exprs) 'array-slice)
		;; The only place for variables is the array name or
		;; the indices
		(check_new_vbles (second exprs))
		(mapc #'check_new_vbles (cdddr exprs)))
111
112
113
	       ((eq (first exprs) 'make-array)
		;;Nothing to do
		)
rtoy's avatar
rtoy committed
114
115
116
117
	       ((cdr exprs)
		;; Have a function call.  Only need to look at the
		;; args for new variables
		(mapc #'check_new_vbles (cdr exprs)))
118
119
	       (t
		(mapc #'check_new_vbles exprs))))
rtoy's avatar
rtoy committed
120
	(t
rtoy's avatar
rtoy committed
121
	 (error "What happened?")))
rtoy's avatar
rtoy committed
122
  exprs)
rtoy's avatar
rtoy committed
123

rtoy's avatar
rtoy committed
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
;; This takes a list of individual Lisp declarations and combines them
;; into one based on the declared type.  Thus
;;
;;  (declare (type fixnum x))
;;  (declare (type fixnum y))
;;  (declare (type single-float z))
;;
;; becomes
;;
;;  (declare (type fixnum x y)
;;           (type single-float z))
(defun pretty-decls (decls)
  (let ((type-hash (make-hash-table :test 'equal)))
    (dolist (decl decls)
      (destructuring-bind (dcl (type v-type var))
	  decl
	(declare (ignore dcl type))
	(let ((val (gethash v-type type-hash)))
	  (setf (gethash v-type type-hash)
		(push var val)))))
    (let ((dec '()))
      (maphash #'(lambda (key val)
		   (push `(type ,key ,@val) dec))
	       type-hash)
      `((declare ,@dec)))))

150
(defun lookup-vble-type (vble &optional (decls *explicit_vble_decls*))
rtoy's avatar
rtoy committed
151
  ;;(format t "lookup-vble: ~a~%" vble)
152
153
  (cond ((or (member vble *declared_vbles*)
	     (member vble *subprog-arglist*))
rtoy's avatar
rtoy committed
154
	 ;;(format t "  is declared var~%")
rtoy's avatar
rtoy committed
155
156
	 ;;(format t "  explicit_vbld_decls = ~A~%" *explicit_vble_decls*)
	 
rtoy's avatar
rtoy committed
157
	 ;; First for declared variables
158
	 (do* ((type-clauses decls
rtoy's avatar
rtoy committed
159
160
161
162
163
			     (rest type-clauses))
	       (type (member vble (cdar type-clauses) :key #'car)
		     (member vble (cdar type-clauses) :key #'car)))
	      ((or type
		   (null type-clauses))
rtoy's avatar
rtoy committed
164
	       (let ((v-type (caar type-clauses)))
165
166
167
168
169
170
171
172
173
174
175
		 (cond ((eq v-type 'array)
			;; Hmm, this is probably an array declared
			;; with a dimension statement, and either the
			;; type is declared later or implicit typing
			;; is used.
			;;
			;; Try to lookup the type again but skip over
			;; array types.  If this works, the array type
			;; was explicitly given so use it. Otherwise,
			;; use Fortran typing rules.
			(cond ((lookup-vble-type vble (remove 'array decls :key #'first)))
rtoy's avatar
rtoy committed
176
			      ((get-implicit-type vble))
rtoy's avatar
rtoy committed
177
			      ((default-int-p vble)
rtoy's avatar
rtoy committed
178
			       'integer4)
179
			      (t (maybe-promote-type 'single-float))))
rtoy's avatar
rtoy committed
180
181
182
183
184
185
186
		       ((and (listp v-type)
			     (eq (first v-type) 'character))
			;; Hmm, a Fortran character string.  Make it a Lisp string
			(if (numberp (second v-type))
			    `(string ,(second v-type))
			    'string))
		       (t
187
188
189
190
191
192
			;; If type is NIL, use implicit type
			(if (null v-type)
			    (cond ((get-implicit-type vble))
				  ((default-int-p vble)
				   'integer4)
				  (t
193
				   (maybe-promote-type 'single-float)))
194
			    v-type))))
rtoy's avatar
rtoy committed
195
196
	       ;;(format t  "type-clause = ~S~%" type-clauses)
	       )))
rtoy's avatar
rtoy committed
197
198
	(t
	 ;;(format t "  is not declared. Implicit type = ~a~%" (get-implicit-type vble))
rtoy's avatar
rtoy committed
199
	 ;;(format t "implicit ~a~%" *implicit_vble_decls*)
rtoy's avatar
rtoy committed
200
201
	 (cond ((get-implicit-type vble))
	       ((default-int-p vble)
rtoy's avatar
rtoy committed
202
		'integer4)
rtoy's avatar
rtoy committed
203
	       (t
204
		(maybe-promote-type 'single-float))))))
rtoy's avatar
rtoy committed
205

206
207
208
209
;; A simple implementation of Fortran contagion.
;;
;; Coerce 0 to the types T1 and T2 and add the result.  The type of
;; the sum is the desired type.  However, we convert some of the types
210
;; to ones that f2cl understands.
rtoy's avatar
rtoy committed
211
(defun fortran-contagion (t1 t2)
212
213
214
215
216
217
218
219
220
221
  (let ((sum (+ (coerce 0 t1) (coerce 0 t2))))
    (typecase sum
      ((complex double-float)
       'complex16)
      ((complex single-float)
       'complex8)
      (integer
       'integer4)
      (t
       (type-of sum)))))
rtoy's avatar
rtoy committed
222

rtoy's avatar
rtoy committed
223
(defun get-fun-arg-type (arg)
rtoy's avatar
rtoy committed
224
  (cond ((symbolp arg)
rtoy's avatar
rtoy committed
225
226
	 (case arg
	   ((%false% %true%)
rtoy's avatar
rtoy committed
227
	    'logical)
rtoy's avatar
rtoy committed
228
	   (t
rtoy's avatar
rtoy committed
229
230
231
232
	    ;; Lookup the variable type and return it.
	    (let ((var-type (lookup-vble-type arg)))
	      (cond ((eq var-type 'array)
		     ;; Look up the type of the array
rtoy's avatar
rtoy committed
233
		     (destructuring-bind (&optional decl1 decl2)
rtoy's avatar
rtoy committed
234
235
			 (vble-declared-twice-p arg *explicit_vble_decls*)
		       (declare (ignorable decl2))
236
237
238
		       (values (first decl1) t)))
		    ((vble-is-array-p arg)
		     (values var-type t))
rtoy's avatar
rtoy committed
239
240
241
		    (t
		     var-type)))
	    )))
rtoy's avatar
rtoy committed
242
243
	((listp arg)
	 ;; We have an expression of some type
rtoy's avatar
rtoy committed
244
	 (let ((fun (first arg)))
245
246
	   (cond ((eq 'make-array fun)
		  ;; Some array slicing here.
247
248
249
		  (values (second (second (member :element-type arg))) t))
		 ((eq 'array-slice fun)
		  (values (get-fun-arg-type (second arg)) t))
250
251
252
		 ((eq 'funcall fun)
		  ;; Look up function type
		  (get-fun-arg-type (second arg)))
253
		 ((eq 'fref fun)
254
255
		  ;; Look up array references.
		  (let ((result (get-fun-arg-type (second arg))))
256
		    (values result nil)))
257
258
259
260
261
262
263
264
		 ((member fun '(+ -))
		  ;; Basic arithmetic operations that might be unary
		  ;; operators.
		  (if (third arg)
		      (fortran-contagion (get-fun-arg-type (second arg))
					 (get-fun-arg-type (third arg)))
		      (get-fun-arg-type (second arg))))
		 ((member fun '(* f2cl/ expt))
rtoy's avatar
rtoy committed
265
266
267
		  ;; Basic arithmetic operations.
		  (fortran-contagion (get-fun-arg-type (second arg))
				     (get-fun-arg-type (third arg))))
rtoy's avatar
rtoy committed
268
269
270
271
		 ((member fun '(conjg))
		  ;; Complex conjugate
		  (fortran-contagion (get-fun-arg-type (second arg))
				     'complex8))
272
273
274
275
276
277
278
279
280
281
		 ((eq fun 'abs)
		  ;; Absolute value
		  (let ((arg-type (get-fun-arg-type (second arg))))
		    (case arg-type
		      (complex8
		       'single-float)
		      (complex16
		       'double-float)
		      (otherwise
		       arg-type))))
rtoy's avatar
rtoy committed
282
283
284
285
286
287
288
		 ((member fun '(cmplx))
		  ;; Complex.  Figure out the type of complex we
		  ;; should return.
		  (fortran-contagion
		   (fortran-contagion (get-fun-arg-type (second arg))
				      (get-fun-arg-type (third arg)))
		   'complex8))
rtoy's avatar
rtoy committed
289
290
291
		 ((member fun '(dcmplx))
		  ;; double complex.  Always returns a complex16
		  'complex16)
rtoy's avatar
rtoy committed
292
293
		 ((member fun '(sin cos tan
				asin acos atan atan2
294
295
				sinh cosh tanh
				exp flog alog10 log10
296
				fsqrt aint sign dim max min))
297
298
299
300
301
302
303
304
		  ;; Generic functions.  These generics always return
		  ;; a number of the same type as its args.  Some
		  ;; functions take more than one arg, but Fortran
		  ;; says they are supposed to be the same type, so we
		  ;; only need to look at the first.  Also, some of
		  ;; them only take real-type arguments.  We don't
		  ;; check for that because Fortran says you're
		  ;; supposed to make sure they are anyway.
rtoy's avatar
rtoy committed
305
306
307
308
		  (get-fun-arg-type (second arg)))
		 ((member fun '(dsin dcos dtan
				dasin dacos datan datan2
				dexp dlog dlog10
309
				dabs dmax1 dmin1
rtoy's avatar
rtoy committed
310
				dble dimag
rtoy's avatar
rtoy committed
311
312
313
				dsqrt))
		  ;; Double-precision functions
		  'double-float)
rtoy's avatar
rtoy committed
314
315
316
317
318
319
320
321
322
323
324
325
326
327
		 ((member fun '(csin ccos ctan
				casin cacos catan catan2
				cexp clog clog10
				cabs 
				csqrt))
		  ;; Complex functions
		  'complex8)
		 ((member fun '(zsin zcos ztan
				zasin zacos zatan zatan2
				zexp zlog zlog10
				zabs 
				zsqrt))
		  ;; Complex functions
		  'complex16)
rtoy's avatar
rtoy committed
328
329
330
		 ((member fun '(and or not > >= equal <= < logeqv logxor))
		  ;; Logical operations
		  'logical)
331
332
		 ((eq fun 'multiple-value-bind)
		  (get-fun-arg-type (third arg)))
rtoy's avatar
rtoy committed
333
334
		 (t
		  (get-fun-arg-type fun)))))
rtoy's avatar
rtoy committed
335
	(t
336
	 ;; If we have a fixnum, return integer4 instead.
337
	 (if (typep arg 'integer)
338
339
	     'integer4
	     (type-of arg)))))
rtoy's avatar
rtoy committed
340
341
342
343
344
345

(defun get-upgraded-fun-arg-type (args)
  (let ((res '()))
    ;;(format t "args = ~a~%" args)
    (dolist (arg args
	     (nreverse res))
rtoy's avatar
rtoy committed
346
347
348
349
350
351
352
353
354
      ;; Handle the simple cases, and then Run down the list and
      ;; lookup the argument types of each.
      (cond ((numberp arg)
	     (push (type-of arg) res))
	    ((symbolp arg)
	     (push (get-fun-arg-type arg) res))
	    ((and (listp arg)
		  (eq 'fref (first arg)))
	     (push (get-fun-arg-type (second arg)) res))
355
356
357
	    ((and (listp arg)
		  (listp (car arg))
		  (eq 'multiple-value-bind (caar arg)))
358
359
360
361
362
363
364
365
	     ;; A call to a function.  Look up the type of the
	     ;; function, but be careful.  Sometimes it's (fun args)
	     ;; and sometimes it's (funcall fun args)
	     (let ((f (third (car arg))))
	       (push (get-fun-arg-type (if (eq (first f) 'funcall)
					   (second (third (car arg)))
					   (first f)))
				       res)))
rtoy's avatar
rtoy committed
366
367
368
369
370
371
372
373
374
375
376
377
378
379
	    (t
	     (let ((arg-types (mapcar #'get-fun-arg-type arg)))
	       (push (cond ((every #'(lambda (x)
				       (eq x (first arg-types)))
				   arg-types)
			    ;; All items are the same, so that's our type.
			    (first arg-types))
			   (t
			    ;; Some items are different, so we can't
			    ;; really say. (Although I think Fortran
			    ;; says they should all have been the
			    ;; same.)
			    `(or ,@arg-types)))
		     res)))))))
rtoy's avatar
rtoy committed
380

381
;; This needs to be reworked!
382
383
384
385
386
387
388
389
(defun get-arg-decl (list-of-arglists)
  (let (res)
    ;; Given a list of arglists, we derive the type for each of the arglists.
    (dolist (arglist list-of-arglists)
      (push (mapcar #'(lambda (arg)
			;; Literal strings (which are of type (string
			;; <len>)) confuse the mapcar below, so change
			;; them into just type 'string.
390
391
392
			(multiple-value-bind (type arrayp)
			    (get-fun-arg-type arg)
			  (cond (arrayp
393
394
				 (if (subtypep type 'string)
				     ;; An array of strings
rtoy's avatar
rtoy committed
395
				     (intern (concatenate 'string (symbol-name '#:array-strings)))
396
				     ;; Some other type of array
rtoy's avatar
rtoy committed
397
				     (intern (concatenate 'string (symbol-name '#:array-) (string type)))))
398
399
				((subtypep type 'string)
				 'string)
400
401
				((subtypep type 'integer4)
				 'integer4)
402
403
				(t
				 type))))
404
405
406
		    arglist)
	    res))
    ;; Now make a list of each of the types of the arguments
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
    (let ((types
	   (mapcar #'(lambda (z)
		       (if (atom z)
			   z
			   (let ((nodup (remove-duplicates z :test #'equalp)))
			     (if (rest nodup)
				 `(or ,@nodup)
				 (first nodup)))))
		   (reduce #'(lambda (x accum)
			       (mapcar #'(lambda (a b)
					   (if (listp a)
					       (cons b a)
					       (list b a)))
				       x accum))
			   res))))
      ;; Remove an extra set of parens if needed.
      (if (and (= (length types) 1) (listp (first types)))
	  (first types)
	  types))))
426

rtoy's avatar
rtoy committed
427
428
429
;; Create declarations for all the functions used in the subprogram.
;; We return three items: statement functions, other functions, and
;; functions in the parameter list of the subprogram.
430
431
432
433
434
435
436
(defun make-fcn-decl (fcn-list arglist)
  (let (stmt-fcns other-fcns arg-fcns)
    (dolist (fcn fcn-list)
      (destructuring-bind ((fname &optional ftype) args)
	  fcn
	;;(format t "declaring fcn ~S~%" fcn)
	;;(format t "fname = ~A~%" fname)
437
	;;(format t "args = ~A~%" args)
438
439
440
441
442
443
444
445
446
447
448
449
	(let* ((type (get-fun-arg-type fcn))
	       ;; If the function is an intrinsic, there is exactly
	       ;; one return value.  If it's not an intrinsic but it
	       ;; is a function, the return values are the function
	       ;; value and the list of arguments.  (This is how f2cl
	       ;; works).  If it's not an intrinsic and is a
	       ;; subroutine (ftype non-NIL), the return type is the
	       ;; list of arguments.  (Should we derive the type of
	       ;; these and put them in the values list?)
	       (decl `(function ,(get-arg-decl args)
		       (values
			,@(if ftype nil (list type))
450
			,@(if (member fname *intrinsic-function-names*)
451
452
			      nil
			      '(&rest t))))))
453
454
455
	  ;;(format t "type = ~A~%" type)
	  ;;(format t "decl = ~A~%" decl)
	  ;;(format t "get-arg-decl = ~A~%" (get-arg-decl args))
456
	  (cond ((member fname *subprog-stmt-fns*)
457
458
		 (push `(declare (ftype ,decl ,fname)) stmt-fcns))
		((member fname arglist)
459
460
461
462
		 ;; What can we really do for a function that appears
		 ;; in the arglist?  We don't really know anything
		 ;; about it, so don't try to declare the function.
		 
463
		 ;;(format t "arglist fcn = ~A~%" `(declare (type ,decl ,fname)))
464
		 #+nil
465
		 (push `(declare (type ,decl ,fname)) arg-fcns))
466
467
468
		((member fname *intrinsic-function-names*)
		 ;; We don't need declarations for intrinsic functions
		 nil)
469
470
471
		(t
		 (push `(declare (ftype ,decl ,fname)) other-fcns))))))
    (values stmt-fcns other-fcns arg-fcns)))
rtoy's avatar
rtoy committed
472

rtoy's avatar
rtoy committed
473
;; Given the program list P, look through it and try to convert all
rtoy's avatar
rtoy committed
474
475
476
477
478
479
480
481
482
483
484
;; occurrences of f2cl/ with either / or TRUNCATE.  We use TRUNCATE if
;; both parameters are integers; / if both parameters are float or
;; complex.  If we can't determine the types of the parameters, we
;; leave it alone.
;;
;; A new tree with the (possibly) modified code is returned.
;;
;; This is an attempt to optimize out the calls to the f2cl/ macro.
;; This is for the benefit of Lisp compilers that aren't smart enough
;; to optimize unused parts of the macros out. (We should probably do
;; a similar thing for sqrt, log, log10.)
rtoy's avatar
rtoy committed
485
486
487
488
489
;;
(defun optimize-f2cl/ (p)
  (cond ((or (atom p) (null p))
	 p)
	((eq (first p) 'f2cl/)
rtoy's avatar
rtoy committed
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
	 ;; Let's try to optimize f2cl/ to either / or truncate
	 ;; appropriately.  If both parameters to f2cl/ are integers,
	 ;; we use truncate; if either parameter is a float or
	 ;; complex, use /.  If we can't determine the type, leave the
	 ;; macro in.

	 (let* ((left (get-fun-arg-type (list (second p))))
		(right (get-fun-arg-type (list (third p))))
		(fun (cond ((and (subtypep left 'integer)
				 (subtypep right 'integer))
			    'truncate)
			   ((or (subtypep left 'number)
				(subtypep right 'number))
			    '/)
			   (t
			    'f2cl/))))
	   `(,fun ,@(mapcar #'optimize-f2cl/ (rest p)))))
	(t
	 `(,(first p) ,@(mapcar #'optimize-f2cl/ (rest p))))))

510
511
512
513
514
515
516
517
518
519
520
521
522
;; Given the program list P, look through it and try to convert all
;; occurrences of integer arithmetic with the integer arithmetic
;; macros.  This is done so that integer arithmetic doesn't have to
;; check for possible overflow because that behavior is undefined in
;; Fortran anyway.
;;
;; A new tree is returned.
(defun optimize-integer-arithmetic (p)
  (cond ((or (atom p) (null p))
	 p)
	((eq (first p) 'declare)
	 ;; Skip over declarations
	 p)
523
524
525
	((eq (first p) 'quote)
	 ;; Skip over quoted objects
	 p)
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
        ((eq (first p) 'fdo)
         ;; FDO handled specially
         (destructuring-bind (fdo (var1 init step-form)
                                  ((cmp-fun var2 end-form) ret-form)
                                  &rest body)
             p
         `(,fdo (,var1 ,(optimize-integer-arithmetic init)
                      ,(optimize-integer-arithmetic step-form))
               ((,cmp-fun ,var2 ,(optimize-integer-arithmetic end-form))
                ,ret-form)
           ,@(mapcar #'optimize-integer-arithmetic body))))
        ((eq (first p) 'fref)
         ;; FREF handled specially
         (destructuring-bind (fref data-var indices bounds &rest offset)
             p
           `(,fref ,data-var ,(mapcar #'optimize-integer-arithmetic indices)
                             ,(mapcar #'optimize-integer-arithmetic bounds)
                             ,@offset)))
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
	((member (first p) '(min max))
	 ;; We might need to do something here because CMUCL doesn't
	 ;; always know how to optimize this right.
	 (let* ((int-args-p
		 (every #'(lambda (e)
			    (eq e 'integer4))
			(mapcar #'(lambda (arg)
				    (let ((res (get-fun-arg-type (list arg))))
				      ;;(format t "arg = type ~A: ~A~%" res arg)
				      res))
				(rest p))))
		(opt-args
		 (mapcar #'optimize-integer-arithmetic (rest p))))
	   ;;(format t "min/max opt. int-args-p = ~A~%" int-args-p)
	   ;;(format t "args = ~A~%" (rest p))
	   ;;(format t "opt-args = ~A~%" opt-args)
	   (if int-args-p
	       `(,(first p) ,@(mapcar #'(lambda (x)
					  `(the integer4 ,x))
				      opt-args))
	       `(,(first p) ,@opt-args))))
	((eq (first p) 'truncate)
	 ;; Hmm, make sure truncate returns a integer4
	 `(the integer4 ,p))
568
569
	((and (member (first p) '(+ - *))
	      (rest p))
570
571
572
573
	 ;; Basic arithmetic operations.  Division has already been
	 ;; handled by converting / to f2cl/ which is optimized
	 ;; somewhere else.
	 
574
575
576
577
	 ;;(format t "expr = ~A~%" p)
	 (let ((fun (if (every #'(lambda (e)
				   (eq e 'integer4))
			       (mapcar #'(lambda (arg)
578
					   (let ((res (get-fun-arg-type arg)))
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
					     ;;(format t "arg = type ~A: ~A~%" res arg)
					     res))
				       (rest p)))
			(cdr (assoc (first p) '((+ . int-add)
						(- . int-sub)
						(* . int-mul))))
			(first p))))
	   `(,fun ,@(mapcar #'optimize-integer-arithmetic (rest p)))))
	((listp (first p))
	 `(,(mapcar #'optimize-integer-arithmetic
		     (first p))
	   ,@(mapcar #'optimize-integer-arithmetic (rest p))))
	(t
	 `(,(first p) ,@(mapcar #'optimize-integer-arithmetic (rest p))))))
  
594
595
596
597
598
599
600
601
602
603
604
605
606
;; Given the program list P, look through it and try to convert all
;; occurrences of external functions with #'<func>.  Do this only if
;; the function is not first element of a list.
;;
;; A new tree with the (possibly) modified code is returned.
;;
(defun fixup-external-function-refs (p externs)
  (cond ((null p)
	 p)
	((atom p)
	 (if (member p externs)
	     `(function ,p)
	     p))
607
608
609
610
611
612
	((eq (first p) 'declare)
	 ;; Skip over declarations
	 p)
	((eq (first p) 'function)
	 ;; Skip over functions that we have already done
	 p)
613
614
615
616
617
618
619
620
621
	((eq (first p) 'funcall)
	 ;; Skip over funcalls!
	 `(,(first p) ,(second p) ,@(mapcar #'(lambda (pp)
						(fixup-external-function-refs pp externs))
					    (cddr p))))
	(t
	 `(,(first p) ,@(mapcar #'(lambda (pp)
				    (fixup-external-function-refs pp externs))
				(rest p))))))
rtoy's avatar
rtoy committed
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640

;; In the following functions, we are trying to simplify some of the
;; expressions produced by f2cl.  We should probably use some real
;; pattern matching algorithm instead of these hand-written matchers.
;;
;; Fix up the expression by destructively modifying it. This tries to
;; convert some expressions produced by f2cl into something more
;; readable:

;; f2cl always converts (- X) to (* -1 X).  This function tries to
;; undo that.  A new tree is returned with the result.
(defun fixup-expr-mul (expr)
  (cond ((or (atom expr) (null expr))
	 expr)
	((and (eq (first expr) '*)
	      (numberp (second expr))
	      (= (second expr) -1))
	 ;; Convert (* -1 X) to (- X)
	 `(- ,@(fixup-expr-mul (rest (rest expr)))))
rtoy's avatar
rtoy committed
641
	(t
rtoy's avatar
rtoy committed
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
	 `(,(first expr) ,@(mapcar #'fixup-expr-mul (rest expr))))))

;; We try to handle some conversions that make the resulting
;; expressions a bit easier to read and more natural.  Also, some of
;; the transformations reduce the number of operations needed.  (These
;; may not be needed if the compiler is smart enough.)
;;
;; F2CL                            RESULT
;; (- N)                           -N        (for numeric N)
;; (+ (- Z) X)                     (- X Z)
;; (op (- Z) X)                    (op -Z X) (for number N, and any function F, except +
;; (+ X (- Z))                     (- X Z)
;; (F X (- Z))                     (F X -Z)  (for F /= + and Z a number)
;; (+ X (op (- Z) Y))              (- X (op Z Y))  (for op = * or /)
(defun fixup-expression (expr) 
  (flet ((is-neg (e)
	   ;; Return T if the e looks something like '(- Z)
	   (and (listp e)
		(eq (first e) '-)
		(= (length e) 2))))
    (cond ((or (atom expr) (null expr))
	   expr)
	  ((eq (first expr) 'fref)
	   ;; Fixup the expressions for the index.
rtoy's avatar
rtoy committed
666
	   ;;(format t "expr = ~S: ~S~%" expr (mapcar #'fixup-expression (third expr)))
rtoy's avatar
rtoy committed
667
668
669
670
671
672
673
674
	   `(fref ,(second expr)
	     ,(mapcar #'fixup-expression (third expr))
	     ,@(if (fourth expr)
		   (list (fourth expr)))))
	  ((eq (first expr) 'fdo)
	   ;; Handle fdo: the fdo macro depends on a certain format
	   ;; for the loop (yuck!  Need to change that!)
	   `(fdo ,(second expr) ,(third expr) ,@(mapcar #'fixup-expression (nthcdr 3 expr))))
675
676
677
678
	  ((and (eq (first expr) '-)
		(numberp (second expr)))
	   ;; Convert (- N) to just -N
	   (- (second expr)))
rtoy's avatar
rtoy committed
679
	  ((is-neg (second expr))
rtoy's avatar
rtoy committed
680
681
	   ;; We have (F (- Z) X ...).  If F is '+,
	   ;; make it (- X Z).  If Z is a number, make it (F -Z X ...)
rtoy's avatar
rtoy committed
682
	   (cond ((eq (first expr) '+)
rtoy's avatar
rtoy committed
683
		  ;; (+ (- Z) X ...) => (- X Z)
rtoy's avatar
rtoy committed
684
		  `(- ,@(mapcar #'fixup-expression (rest (rest expr)))
rtoy's avatar
rtoy committed
685
		      ,@(mapcar #'fixup-expression (rest (second expr)))))
rtoy's avatar
rtoy committed
686
687
688
689
		 ((numberp (second (second expr)))
		  `(,(first expr) ,(- (second (second expr)))
		    ,@(mapcar #'fixup-expression (rest (rest expr)))))
		 (t
690
		  `(,@(mapcar #'fixup-expression expr)))))
rtoy's avatar
rtoy committed
691
	  ((is-neg (third expr))
rtoy's avatar
rtoy committed
692
693
	   ;; We have (F X (- Z) ...).  If F is '+, convert to (- X Z).
	   ;; If not, but Z is a number, convert to (F X -Z ...).
rtoy's avatar
rtoy committed
694
695
696
697
698
	   (cond ((eq '+ (first expr))
		  ;; We have '(+ X (- Z)).  Make that '(- X Z)
		  `(- ,@(mapcar #'fixup-expression (list (second expr)))
		      ,@(mapcar #'fixup-expression (list (second (third expr))))))
		 ((numberp (second (third expr)))
rtoy's avatar
rtoy committed
699
		  ;; We have (F X (- N) ...).  Make that (F X -N ...)
rtoy's avatar
rtoy committed
700
		  `(,(first expr) ,@(mapcar #'fixup-expression (list (second expr)))
rtoy's avatar
rtoy committed
701
702
		                  ,(- (second (third expr)))
		                  ,@(mapcar #'fixup-expression (nthcdr 3 expr))))
rtoy's avatar
rtoy committed
703
704
		 (t
		  ;; Process the X and (- Z) parts now
rtoy's avatar
rtoy committed
705
		  ;;(format t "T case (F X (- Z) ...): ~S~%" expr)
rtoy's avatar
rtoy committed
706
		  `(,(first expr) ,(fixup-expression (second expr))
rtoy's avatar
rtoy committed
707
		                  ,@(mapcar #'fixup-expression (rest (rest expr)))))))
rtoy's avatar
rtoy committed
708
709
710
711
712
713
714
715
716
717
	  ((and (eq (first expr) '+)
		(listp (third expr))
		(member (first (third expr)) '(* /))
		(listp (second (third expr)))
		(eq (first (second (third expr))) '-))
	   ;; We have (+ X (op (- Z) Y)).  Convert to (- X (op Z Y)), for op = * or /.

	   ;;(format t "got ~S~%" expr)
	   `(- ,(fixup-expression (second expr))
	     (,(first (third expr))
rtoy's avatar
rtoy committed
718
719
	      ,@(mapcar #'fixup-expression (rest (second (third expr))))
	      ,@(mapcar #'fixup-expression (rest (rest (third expr)))))))
rtoy's avatar
rtoy committed
720
721
722
	  (t
	   ;; Didn't match, so descend into the remaining args
	   `(,(first expr) ,@(mapcar #'fixup-expression (rest expr)))))))
723
724
725
726
727
728

(defun fixup-relop (expr)
  (cond ((or (null expr)
	     (atom expr)
	     (typep expr 'string))
	 expr)
rtoy's avatar
rtoy committed
729
	((member (first expr) '(|>=| |<=| equal |/=| < > =))
730
731
732
733
734
735
736
	 ;; If one arguments is a string, replace operation with the
	 ;; appropriate string operation.
	 (let ((lhs (get-fun-arg-type (list (second expr))))
	       (rhs (get-fun-arg-type (list (third expr)))))
	   (cond ((or (subtypep lhs 'string)
		      (subtypep rhs 'string))
		  (let ((op (intern (concatenate 'string
rtoy's avatar
rtoy committed
737
						 (symbol-name '#:fstring-)
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
						 (symbol-name (first expr))))))
		    `(,op ,(second expr) ,(third expr))))
		 (t
		  expr))))
	(t
	 `(,@(mapcar #'fixup-relop expr)))))

(defun merge-ops (expr)
  (cond ((or (null expr)
	     (atom expr)
	     (typep expr 'string))
	 expr)
	((and (third expr)
	      (member (first expr) '(+ * - /)))
	 ;; Try to merge a bunch of +, *, -, / operations into one.
753
	 (destructuring-bind (op next &rest args)
754
	     expr
755
756
757
758
759
760
	   ;;(setf args (list args))
	   (when (and (listp next) (third next))
	     (loop while (and (listp next) (eq op (first next)))
	       do
	       (push (third next) args)
	       (setf next (second next))))
761
762
763
764
	   `(,op ,(merge-ops next) ,@(merge-ops args))))
	(t
	 `(,@(mapcar #'merge-ops expr)))))
	 
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820

(defun find-sym (sym code)
  (cond ((atom code)
	 (eq sym code))
	((null code)
	 nil)
	(t
	 (or (find-sym sym (car code))
	     (find-sym sym (cdr code))))))

(defun remove-unused-sym-macros (sym-mlets sym-lets prog-bit)
  #+(or)
  (progn
    (format t "sym-mlets = ~S~%" sym-mlets)
    (format t "sym-lets  = ~S~%" sym-lets)
    (format t "prog =~%~S~%" prog-bit))
  (let ((new-sym-mlets nil)
	(new-sym-lets nil))
    ;; For each symbol in sym-mlets, look to see if it is used in
    ;; prog-bit.  If so, keep it.
    (dolist (mlet sym-mlets)
      (let ((sym (car mlet)))
	(when (find-sym sym prog-bit)
	  (push mlet new-sym-mlets))))
    (setf new-sym-mlets (nreverse new-sym-mlets))
    ;;(format t "new-sym-mlets = ~S~%" new-sym-mlets)
    ;; Look through sym-lets for things that match our new symbol
    ;; macros.  Save the matches, discarding the rest.
    (dolist (mlet new-sym-mlets)
      (when (atom (second mlet))
	(let ((item (find (second mlet) sym-lets :key #'first)))
	  (push item new-sym-lets))))
    (setf new-sym-lets (nreverse new-sym-lets))
    ;;(format t "new-sym-lets = ~S~%" new-sym-lets)
    (values new-sym-mlets new-sym-lets)))

(defun remove-unused-key-params (keys code)
  (let ((used-keys nil))
    (dolist (key keys)
      (let ((keyname (first key)))
	;; If the key is used in other keys, we need to keep it.
	;; Otherwise, look throught the code to see if the key is
	;; used.  If so, keep it too.
	(if (find-if #'(lambda (k)
			 (if (atom k)
			     (eq keyname k)
			     (member keyname k)))
		     keys :key #'second)
	    (push key used-keys)
	    (when (find-sym keyname code)
	      (push key used-keys)))))
    (setf used-keys (nreverse used-keys))
    (values used-keys)))


(defun create-sym-macros (prog-bit)
821
822
  (let ((sym-mlets '())
	(sym-lets ()))
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
    (if *common-blocks-as-arrays*
	(let ((common-var-decls (mapcar #'make-special-var-decl *subprog_common_vars*)))
	  (setf common-var-decls (append '(declaim)
					 (mapcar #'(lambda (decl)
						     (second decl))
						 common-var-decls)))
	  (multiple-value-setq (sym-mlets sym-lets)
	    (create-sym-macros-array common-var-decls)))
	(maphash
	 #'(lambda (key varlist)
	     (mapc #'(lambda (var)
		       (let ((accessor-name
			      (intern (concatenate 'string
						   (symbol-name key)
						   "-"
						   (symbol-name var))))
			     (name
			      (intern (concatenate 'string
						   "*"
						   (symbol-name key)
						   (symbol-name '#:-common-block*)))))
			 (if (vble-is-array-p var)
			     (progn
			       (push `(,accessor-name (,accessor-name ,name)) sym-lets)
			       (push `(,var ,accessor-name) sym-mlets))
			     (push `(,var (,accessor-name ,name)) sym-mlets))
			 ))
		   varlist))
	 *common-blocks*))
852
853
854
    (multiple-value-bind (new-sym-mlets new-sym-lets)
	(remove-unused-sym-macros sym-mlets sym-lets prog-bit)
      (values new-sym-mlets new-sym-lets))))
855

856
857
858
(defun create-sym-macros-array (common_var_decls)
  (let ((sym-mlets '())
	(sym-lets ()))
rtoy's avatar
rtoy committed
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
    (labels
	((create (key v var-type part posn len arrayp)
	   #+nil
	   (format t "var = ~A :type ~A Part ~A posn ~A~%"
		   v var-type part posn)
	   (let ((accessor-name
		  (intern (format nil "~A-~A" key v)))
		 (name
		  (intern (format nil "*~A-COMMON-BLOCK*" key)))
		 (part-name (intern (format nil "~A-PART-~D" key part))))
	     (if arrayp
		 (progn
		   (push `(,accessor-name
			   (make-array ,len :element-type ',(second var-type)
				       :displaced-to (,part-name ,name)
				       :displaced-index-offset ,posn))
			 sym-lets)
		   (push `(,v ,accessor-name) sym-mlets))
		 (push `(,v (aref (,part-name ,name) ,posn))
		       sym-mlets))))
	 (process-block (key varlist)
	   (let ((part 0)
881
882
883
884
885
886
887
888
		 (prev-type nil)
		 (total-len 0)
		 (posn 0))
	     (dolist (v varlist)
	       (let* ((decl (find v (rest common_var_decls) :key #'third))
		      (var-type (if decl (second decl) nil))
		      (el-type (if (subtypep var-type 'array)
				   (second var-type)
rtoy's avatar
rtoy committed
889
				   var-type)))
890
891
892
893
894
895
		 (unless prev-type
		   (setf prev-type el-type))
		 (multiple-value-bind (len arrayp)
		     (if (subtypep var-type 'array)
			 (values (first (third var-type)) t)
			 (values 1 nil))
896
897
		   (unless (and (subtypep el-type prev-type)
				(subtypep prev-type el-type))
rtoy's avatar
rtoy committed
898
899
900
901
902
903
904
905
		     (setf prev-type el-type)
		     (incf part)
		     (setf total-len 0)
		     (setf posn 0))
		       
		   (create key v var-type part posn len arrayp)
		   (incf total-len len)
		   (incf posn len)))))))
906
907
908
909
910
911
912
      (maphash #'process-block *common-blocks*)
      (setf sym-mlets (nreverse sym-mlets))
      (setf sym-lets (nreverse sym-lets))
      ;;(format t "sym-mlets = ~S~%" sym-mlets)
      ;;(format t "sym-lets  = ~S~%" sym-lets)
      (values sym-mlets sym-lets))))

913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
(defun coerce-parameter-assign (lhs rhs)
  (let* ((lhs-type (first (get-upgraded-fun-arg-type (list (list lhs)))))
	 (rhs-type (first (get-upgraded-fun-arg-type (list (list rhs))))))
    ;;(format t "~&")
    ;;(format t "lhs = ~A, type ~A~%" lhs lhs-type)
    ;;(format t "rhs = ~A, type ~A~%" rhs rhs-type)
    (cond ((subtypep lhs-type 'string)
	   (warn "Assignment of string in parameter statements may not be right.")
	   rhs)
	  (t
	   (let ((new-rhs
		  (cond ((find *coerce-assignments* '(t :always))
			 `(coerce ,rhs (type-of ,lhs)))
			((find *coerce-assignments* '(nil :never))
			 rhs)
			(t
			 ;;(format t "rhs-type, rhs = ~S ~S~%" rhs-type rhs)
			 ;; RHS.  Otherwise, coerce the RHS to the
			 ;; type of the LHS.  However, we can't coerce
			 ;; something to an integer.  Use truncate for
			 ;; that.
			 (cond ((or (eq t rhs-type)
				    (eq t lhs-type)
				    (subtypep rhs-type lhs-type))
				;; No coercion is needed if the types
				;; match, or if we can't determine the
				;; type of the LHS or RHS.
				rhs)
			       ((and (subtypep lhs-type 'integer)
				     (not (subtypep rhs-type 'integer)))
				;; We're trying to set a integer
				;; variable to non-integer value.  Use
				;; truncate.
946
				`(int ,rhs))
947
948
949
950
951
			       (t
				;; Haven't a clue, so coerce
				`(coerce ,rhs ',lhs-type)))))))
	     new-rhs)))))

952
953
954
955
956
957
958
959
960
(defun flatten-list (x)
  (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
	     (cond ((null x) r)
		   ((atom x)
		    (cons x r))
		   (t (flatten-helper (car x)
				      (flatten-helper (cdr x) r))))))
    (flatten-helper x nil)))

961
#+nil
962
963
964
965
966
967
968
969
(defun entry-functions (entry main args)
  (flet ((make-vars (n)
	   (let ((v '()))
	     (dotimes (k n)
	       (push (intern (format nil "V~D" k)) v))
	     (nreverse v)))
	 (select-vars (k n vlist)
	   (append (list (elt vlist k))
970
971
972
973
974
		   (subseq vlist n)))
	 (make-ignore (k n vlist)
	   (append (subseq vlist 0 k)
		   (subseq vlist (1+ k) n)))
	   )
975
976
977
978
979
980
981
    (let* ((count 0)
	   (n-entries (1+ (length *entry-points*)))
	   (n-returns (+ n-entries (length args)))
	   (vlist (make-vars n-returns)))
      (cons `(defun ,main ,args
	      (multiple-value-bind ,vlist
		  (,entry ',main ,@args)
982
		(declare (ignore ,@(make-ignore 0 n-entries vlist)))
983
984
985
986
987
988
989
		(values ,@(select-vars 0 n-entries vlist))))
	    (mapcar #'(lambda (x)
			(let ((vlist (make-vars n-returns)))
			  (incf count)
			  `(defun ,(first x) ,@(rest x)
			    (multiple-value-bind ,vlist
				(,entry ',(first x) ,@(second x))
990
			      (declare (ignore ,@(make-ignore count n-entries vlist)))
991
992
993
994
			      (values ,@(select-vars count n-entries vlist))))
			  ))
		    *entry-points*)))))

995
996
997
998
999
1000
(defun entry-functions (entry main args)
  (flet ((make-vars (n)
	   (let ((v '()))
	     (dotimes (k n)
	       (push (intern (format nil "V~D" k)) v))
	     (nreverse v)))
1001
	 #+nil
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
	 (make-ignore (k n vlist)
	   (append (subseq vlist 0 k)
		   (subseq vlist (1+ k) n)))
	   )
    (let* ((count 0)
	   (n-returns (length args))
	   (vlist (make-vars n-returns)))
      (cons `(defun ,main ,args
	      (multiple-value-bind ,vlist
		  (,entry ',main ,@args)
		(values ,@vlist)))
	    (mapcar #'(lambda (x)
			(let ((vlist (make-vars n-returns)))
			  (incf count)
1016
			  `(defun ,(first x) ,@(butlast (rest x))
1017
1018
1019
1020
1021
			    (multiple-value-bind ,vlist
				(,entry ',(first x) ,@(second x))
			      (values ,@vlist)))))
		    *entry-points*)))))

1022
1023
1024
1025
1026
1027
1028
1029
1030
1031

(defvar *enable-merging-data-and-save-init* t)

;; This is kind of experimental (and a very, very gross
;; implementation!).  What we're trying to do is move all of the data
;; initialization statements for arrays (from DATA statements) into
;; the initialization of the variable itself.  This makes the code
;; look like more idiomatic Lisp and it seems to help out compilers
;; quite a bit.
(defun merge-data-and-save-inits (saves data)
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
  (labels ((find-inits (name)
	     ;; Look through the data init statements to find an array
	     ;; initializer for our specified variable NAME.  The
	     ;; initializer will look something like (FSET (FREF VAR
	     ;; index limits) value).  Return a list of all matches as
	     ;; the first value.  The scond value indicates if this is a
	     ;; 1D array.
	     (let ((inits '())
		   (1d-array-p t))
	       (dolist (item data)
1042
1043
1044
		 ;; FIXME: This critically depends on FSET being used
		 ;; to initialize the values for DATA statements.  If
		 ;; this is changed, we need to change this!  (Gross!)
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
		 (when (eq 'fset (first item))
		   (destructuring-bind (fset (fref var-name indices &rest dims) value)
		       item
		     (declare (ignore fset fref dims value))
		     (when (and (eq var-name name))
		       (push item inits)
		       (unless (= 1 (length indices))
			 (setf 1d-array-p nil))))))
	       (values (nreverse inits) 1d-array-p)))
	   (col-major-index (indices limits)
1055
1056
1057
1058
1059
	     ;; Compute the column major index given the set of
	     ;; indices and bounds.  Given indicies (i1 i2 ... in) and
	     ;; limits ((l1 h1) (l2 h2) ... (ln hn)), the colum-major
	     ;; index as used by Fortran would be
	     ;;
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
	     ;; (i1 - l1) +
	     ;;   (h1-l1+1)*((i2 - l2) +
	     ;;                (h2-l2+1)*((i3 - l3) +
	     ;;                             (h3 - l3 + 1) * ...)))
	     ;;
	     ;; See col-major-index in macros.l too.
	     (if (null indices)
		 0
		 (destructuring-bind (lo hi)
		     (car limits)
		   (+ (- (car indices)
			 lo)
		      (* (1+ (- hi lo))
rtoy's avatar
rtoy committed
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
			 (col-major-index (rest indices) (rest limits)))))))
	   (find-array-dims (dims)
	     ;; If the dimensions are numbers return them.  If they're
	     ;; not, we could look in the parameter variables to see
	     ;; if we can figure it out.  Return NIL if we can't
	     ;; figure out the dimensions.
	     (cond ((listp dims)
		    ;; Must be of the form (quote (a ...)).  Strip of quote
		    (when (every #'integerp (cdr dims))
		      dims))
		   ((integerp dims)
		    dims)
		   (t
		    nil))))
1087
	 
1088
    (let ((new-saves '())
1089
1090
	  (new-data '())
	  (array-element-inits '()))
1091
1092
      ;; First, save all non-array data initializers.
      (dolist (item data)
1093
	;;(format t "data item = ~S~%" item)
1094
1095
1096
	(if (eq 'fset (first item))
	    (push (cdr item) array-element-inits)
	    (push item new-data)))
1097
1098
1099
1100
      #+nil
      (progn
	(format t "new-data = ~A~%" new-data)
	(format t "array-element-inits = ~A~%" array-element-inits))
1101
1102
      ;; Now look through all the saved vars
      (dolist (item saves)
1103
	;;(format t "save item = ~S~%" item)
1104
1105
1106
1107
	(cond ((and (listp (second item))
		    (eq 'make-array (first (second item))))
	       ;; Got an array.  Look for initializers in DATA.
	       (let ((type (second (fourth (second item))))
rtoy's avatar
rtoy committed
1108
1109
		     (inits (find-inits (first item)))
		     (array-dims (find-array-dims (second (second item)))))
1110
1111
1112
1113
		 #+nil
		 (progn
		   (format t "~D inits for ~S: ~S~%" (length inits) (first item) inits)
		   (format t "dims = ~S: ~A~%" (second (second item))
rtoy's avatar
rtoy committed
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
			   array-dims))
		 (cond ((and inits array-dims)
			(let ((init (make-array array-dims
						:element-type type
						:initial-element
						(if (subtypep type 'character)
						    #\space
						    (coerce 0 type)))))
			  ;; Gather up the values into an array to be
			  ;; used for initializing the variable.  The
			  ;; array is initialized to zero (of the
			  ;; appropriate type).  If the original code
			  ;; didn't initialize it, then it didn't
			  ;; care.
			  (dolist (i inits)
			    (destructuring-bind (fset (fref var indices limits) val)
				i
			      (declare (ignore fset fref var))
			      (setf (aref init (col-major-index indices limits))
				    val)))
			  (push (list (car item)
				      (append (copy-list (second item))
					      `(:initial-contents ',(coerce init 'list))))
				new-saves))
			;; Remove these from array-element-inits
			(let ((array-name (first item)))
			  (setf array-element-inits
				(remove array-name
					array-element-inits
					:key #'cadar))))
		       (t
			;; Save it as is.
			(push item new-saves)))))
1147
	      ((and (listp (second item))
1148
1149
1150
1151
1152
1153
1154
1155
		    (eq 'f2cl-init-string (first (second item)))
		    (not (fourth (second item))))
	       ;; We have something like
	       ;;
	       ;; (<var> (f2cl-init-string (<dims>) (<stringlen>) <inits>))
	       ;;
	       ;; Initializing an array of strings, but only if the
	       ;; initializer isn't already given.  We don't do
1156
	       ;; anything special right now.
1157
1158
1159
1160
1161
1162
	       (let ((inits (find-inits (first item))))
		 #+nil
		 (progn
		   (format t "inits for ~S: ~S~%" (first item) inits)
		   (format t "dims = ~S: ~A~%" (second (second item))
			   (reduce #'* (second (second item)))))
rtoy's avatar
rtoy committed
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
		 (cond
		   (inits
		    (let ((init (make-array (length inits)
					    :initial-element
					    (make-string (car (third (second item)))))))
		      ;; Gather up the values into an array to be
		      ;; used for initializing the variable.  The
		      ;; array is initialized to zero (of the
		      ;; appropriate type).  If the original code
		      ;; didn't initialize it, then it didn't
		      ;; care.
		      (dolist (i inits)
			(destructuring-bind (fset (fref var indices limits) val)
			    i
			  (declare (ignore fset fref var))
			  (setf (aref init (col-major-index indices limits))
				val)))
		      (push (list (car item)
				  (append (butlast (copy-list (second item)))
					  (list (coerce init 'list))))
			    new-saves))
		    ;; Remove these from array-element-inits
		    (let ((array-name (first item)))
		      (setf array-element-inits
			    (remove array-name
				    array-element-inits
				    :key #'cadar))))
		   (t
		    (push item new-saves)))))
1192
1193
1194
	      (t
	       ;; Not an array
	       (push item new-saves))))
1195
1196
1197
1198
1199
1200
1201
1202
      (cond (array-element-inits
	     (warn "Bug in f2cl:  ~D array element initializers still left:~% ~S~%Merging not done."
		   (length array-element-inits) array-element-inits)
	     (values saves data))
	    (t
	     (values (append (nreverse new-saves)
			     (nreverse array-element-inits))
		     (nreverse new-data)))))))
1203

1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
(defun verify-and-generate-equivalences ()
  ;; Look over equivalences and see if we can handle them.  Right now,
  ;; we can only handle equivalences of the form (array, simple) or
  ;; (simple, array), and they must have the same type.
  ;;
  ;; So, if we have something like (x, y(4)), we can use a
  ;; symbol-macrolet to make x equivalent to y(4).
  (flet ((verify-types (array b)
	   #+nil
	   (progn
	     (format t "Type of array: ~A = ~A (~A)~%" array (lookup-vble-type array)
		     (vble-is-array-p array))
	     (format t "Type of a: ~A = ~A~%" b (lookup-vble-type b))
	     (format t "explicit-vars = ~A~%" *explicit_vble_decls*)
	     (format t "*declared_vbles* = ~A~%" *declared_vbles*))
	   (assert (vble-is-array-p array))
	   (let ((a-type (lookup-vble-type array))
		 (b-type (lookup-vble-type b)))
	     (unless (eq a-type b-type)
	       (error "f2cl cannot equivalence variables of different types: ~A (~A) and ~A (~A)"
		      array a-type b b-type))))
	 (gen-fref (a)
	   a))
    (let (res simple)
      (dolist (equiv *equivalenced-vars*)
	(cond ((and (symbolp (first equiv))
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
		    (symbolp (second equiv)))
	       ;; Equivalence of two simple vars.  Just make one a
	       ;; symbol-macrolet of the other, if the types match.
	       (let ((a-type (lookup-vble-type (first equiv)))
		     (b-type (lookup-vble-type (second equiv))))
		 (unless (eq a-type b-type)
		   (error "f2cl cannot equivalence variables of different types: ~A (~A) and ~A (~A)"
			  (first equiv) a-type (second equiv) b-type))
		 (push (first equiv) simple)
		 (push `(,(first equiv) ,(second equiv)) res)))
	      ((and (symbolp (first equiv))
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
		    (listp (second equiv))
		    (eq (car (second equiv)) 'fref))
	       ;; (simple, array)
	       ;; We want (symbol-macrolet (simple expansion))
	       (verify-types (second (second equiv)) (first equiv))
	       (push `(,(first equiv) ,(gen-fref (second equiv))) res)
	       (push (first equiv) simple))
	      ((and (symbolp (second equiv))
		    (listp (first equiv))
		    (eq (car (first equiv)) 'fref))
	       ;; (array, simple)
	       (verify-types (second (first equiv)) (second equiv))
	       (push `(,(second equiv) ,(gen-fref (first equiv))) res)
	       (push (second equiv) simple))
	      (t
rtoy's avatar
rtoy committed
1256
1257
	       (format t "~S~%" (first equiv))
	       (format t "~S~%" (second equiv))
1258
1259
1260
1261
	       (error "f2cl cannot handle EQUIVALENCE of ~A and ~A~%"
		      (first equiv) (second equiv)))))
      (values (nreverse res) (nreverse simple)))))

1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
(defun get-var-types (arglist &key declare-vars)
  "Compute the types of each variable in ARGLIST and also an
  appropriate declaration for each variable, if DECLARE-VARS is
  non-NIL."
  (let ((var-decls nil)
	(var-type-list nil))
    (dolist (vble arglist)
      (if (or (member vble *external-function-names*)
	      (member vble *functions-used*
		      :key #'caar))
	  (push t var-type-list)
1273
	(let ((decl (make-declaration vble :vble-is-formal-arg t)))
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
	  (destructuring-bind (declare-sym (type-sym type var))
	      decl
	    (declare (ignore declare-sym type-sym var))
	    (when declare-vars
	      (push decl var-decls))
	    (setf *declared_vbles*
		  (remove vble *declared_vbles*))
	    (setf *undeclared_vbles*
		  (remove vble *undeclared_vbles*))
	    (push type var-type-list)))))
    (values (nreverse var-type-list)
	    (nreverse var-decls))))
1286

1287
1288
1289
1290
1291
1292
1293
1294
1295
(defun make-key-param-decls (keys)
  (let ((code-key-params-decls
	 (mapcar #'(lambda (param)
		     (destructuring-bind (v val)
			 param
		       (make-declaration v :parameterp (if (numberp val) val nil))))
		 keys)))

    (setf code-key-params-decls
1296
1297
	  `((declare ,@(mapcan #'cdr code-key-params-decls)
		     (ignorable ,@(mapcar #'car keys)))))
1298
    code-key-params-decls))
1299

rtoy's avatar
rtoy committed
1300
(defun insert-declarations (fort-fun) 
rtoy's avatar
rtoy committed
1301
  (prog (defun-bit arglist prog-bit formal-arg-decls common_var_decls
1302
		   local-vbles vble-decls body common-blocks
rtoy's avatar
rtoy committed
1303
1304
1305
		   saved-decls save-inits
		   other-fcn-decls
		   stmt-fcn-decls
rtoy's avatar
rtoy committed
1306
		   arg-fcn-decls
rtoy's avatar
rtoy committed
1307
1308
		   common-block-structs
		   key-params
1309
		   key-params-decls
1310
1311
	           code-key-params
	 	   code-key-params-decls
1312
		   all-decls
1313
		   #+nil additional-args
1314
		   entry-points equivalences)
rtoy's avatar
rtoy committed
1315
1316
1317
1318

     (setq defun-bit (list (car fort-fun) (cadr fort-fun))
	   arglist (caddr fort-fun)
	   body (cdddr fort-fun))
rtoy's avatar
rtoy committed
1319
1320
     (setq *undeclared_vbles* 
	   (set-difference *undeclared_vbles* *subprog_common_vars*))
rtoy's avatar
rtoy committed
1321
1322
1323
1324
1325
1326
     (when (member :insert-declaration *f2cl-trace*)
       (format t "~&")
       (format t "declared_vbles   = ~S~%" *declared_vbles*)
       (format t "undeclared_vbles = ~S~%" *undeclared_vbles*)
       (format t "implicit_vbles   = ~S~%" *implicit_vble_decls*)
       (format t "*functions used* = ~S~%" *functions-used*)
1327
       (format t "external func    = ~S~%" *external-function-names*)
1328
1329
       (format t "*subprog_common_vars* = ~S~%" *subprog_common_vars*)
       (format t "*common_array_dims*   = ~S~%" *common_array_dims*)
rtoy's avatar
rtoy committed
1330
1331
1332
1333
       (format t "*explicit_vble_decls* = ~A~%" *explicit_vble_decls*)
       (maphash #'(lambda (key val)
		    (format t "~A => ~A~%" key val))
		*common-blocks*))
1334
1335
     ;;(setq special-proclamation (make-special-proclamation *subprog_common_vars*))
     #+nil
rtoy's avatar
rtoy committed
1336
1337
     (when (member :insert-declaration *f2cl-trace*)
       (format t "special-proclamation = ~a~%" special-proclamation))
rtoy's avatar
rtoy committed
1338
     (setq common_var_decls 
rtoy's avatar
rtoy committed
1339
	   (mapcar #'make-special-var-decl *subprog_common_vars*))
rtoy's avatar
rtoy committed
1340
1341
1342
1343
1344
1345
1346
     ;; Clean up the declarations by merging them into one
     (setq common_var_decls
	   (append '(declaim)
		   (mapcar #'(lambda (decl)
			       (second decl))
			   common_var_decls)))

rtoy's avatar
rtoy committed
1347
     ;;(format t "*subprog_common_vars* = ~S~%" *subprog_common_vars*)
1348
     ;;(format t "*common_array_dims* = ~S~%" *common_array_dims*)
rtoy's avatar
rtoy committed
1349
     ;;(format t "declared = ~S~%" common_var_decls)
1350
     
rtoy's avatar
rtoy committed
1351
     (setf common-block-structs (make-common-block-structure common_var_decls))
rtoy's avatar
rtoy committed
1352
1353
     (when (member :insert-declaration *f2cl-trace*)
       (format t "struct = ~S~%" common-block-structs))
rtoy's avatar
rtoy committed
1354

1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
     (setq common-blocks
	   (if *declare-common-blocks*
	       common-block-structs
	       nil))

     (when (member :insert-declaration *f2cl-trace*)
       (format t "*declare-common-blocks* = ~S~%" *declare-common-blocks*)
       (format t "spec-proc = ~S~%" common-blocks))
     
     ;;(format t "common-blocks = ~a~%" common-blocks)
rtoy's avatar
rtoy committed
1365

rtoy's avatar
rtoy committed
1366
1367
1368
1369
     ;; Get the declarations for all functions
     (multiple-value-setq (stmt-fcn-decls other-fcn-decls arg-fcn-decls)
       (make-fcn-decl *functions-used* arglist))

1370
     #+nil
rtoy's avatar
rtoy committed
1371
1372
1373
     (setq formal-arg-decls
	   (pretty-decls
	    (append
1374
	     ;; Declare any function arguments
rtoy's avatar
rtoy committed
1375
1376
1377
1378
1379
1380
1381
	     (if (equalp arg-fcn-decls '((declare)))
		 nil
		 arg-fcn-decls)
	     ;; Declare variables
	     (mapcar #'(lambda (vble)
			 (let ((decl
				(make-declaration vble :vble-is-formal-arg t)))
1382
			   (format t "~S: ~S is ~S~%" defun-bit vble decl)
rtoy's avatar
rtoy committed
1383
1384
1385
1386
			   (setf *declared_vbles*
				 (remove vble *declared_vbles*))
			   (setf *undeclared_vbles*
				 (remove vble *undeclared_vbles*))
rtoy's avatar
rtoy committed
1387
			   decl))
1388
		     (set-difference arglist *external-function-names*)))))
1389
     ;;(format t "*functions used* = ~S~%" *functions-used*)
1390
1391
1392
     (let* ((var-decls nil)
	    (var-type-list
	      (mapcar #'(lambda (vble)
1393
1394
1395
			  (if (or (member vble *external-function-names*)
				  (member vble *functions-used*
					  :key #'caar))
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
			      t
			      (let ((decl
				     (make-declaration vble :vble-is-formal-arg t)))
				(destructuring-bind (declare-sym (type-sym type var))
				    decl
				  (declare (ignore declare-sym type-sym var))
				  (push decl var-decls)
				  (setf *declared_vbles*
					(remove vble *declared_vbles*))
				  (setf *undeclared_vbles*
					(remove vble *undeclared_vbles*))
				  type))))
		      arglist)
	      ))
       (setf var-decls (nreverse var-decls))

rtoy's avatar
rtoy committed
1412
       ;; (format t "declare ~S: ~S~%" (second defun-bit) var-type-list)
1413
1414
       (let ((entry (gethash (second defun-bit) *f2cl-function-info*)))
	 (if entry
1415
	     (setf (f2cl-finfo-arg-types entry) (relax-array-decl var-type-list))
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
	     (setf (gethash (second defun-bit) *f2cl-function-info*)
		   (make-f2cl-finfo :arg-types var-type-list))))
       (setq formal-arg-decls
	   (pretty-decls
	    (append
	     ;; Declare any function arguments
	     (if (equalp arg-fcn-decls '((declare)))
		 nil
		 arg-fcn-decls)
	     ;; Declare variables
	     var-decls))))