source: src/f2cl5.l @ 1140:46c1f6a93b0d

Last change on this file since 1140:46c1f6a93b0d was 1140:46c1f6a93b0d, checked in by Raymond Toy <toy.raymond@…>, 2 years ago

Don't declare strings as (simple-array character). In general that's
incorrect for literal strings because they can be base-strings or
strings, depending on the implementation. (Ecl does this).

Thus, just declare them as simple-strings which includes all string
types.

File size: 176.4 KB
Line 
1; -*- Mode: lisp; package: F2CL -*-
2; f2cl5.l
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7;functions:
8; declaration insertion
9;      check_new_vbles
10;      insert-declarations
11;      make-initialisation
12;      make-declaration
13;      make-char-decl
14;      make-char-init
15;      get-implicit-type
16;      get_array_type
17;      default-int-p
18;      vble-is-array-p
19;      sym-is-fun-name
20;      make-special-proclamation
21;      make-special-var-decl
22;      check-reserved-lisp-names
23; structured stmt fix
24;      fix-structure
25;      fix-ifthen
26;      end-do-p
27;      label-matches-dolabel-p
28;      fix-do
29;      fix-tagbodies
30;      remove-prefix
31;      multiple-do-labelp
32; FORMAT parsing
33;      parse-format
34;      parse-format1
35;      parse-write
36;      parse-format-descriptor-list
37;      fixnum-string
38;      parse-format-descriptor-I
39;      parse-format-descriptor-F
40;      parse-format-descriptor-E
41;      parse-format-descriptor-G
42;      parse-format-descriptor-/
43;      parse-format-descriptor-TR
44;      parse-format-descriptor-X
45;      parse-format-descriptor-S
46;      parse-default-format-descriptor
47;      fix-slashes
48
49;;-----------------------------------------------------------------------------
50(in-package :f2cl)
51
52(defparameter *f2cl5-version*
53  "$Id$")
54
55;; functions for setting up varaible declarations and initialisations
56(eval-when (compile load eval)
57  (proclaim '(special *intrinsic-function-names* *external-function-names*
58              *declared_vbles* *undeclared_vbles* *key_params* *save_vbles*
59              *explicit_vble_decls* *implicit_vble_decls* *common_array_dims*
60              *subprog_common_vars* *program-flag*
61              *subprog-stmt-fns* *subprog_stmt_fns_bodies*
62              *auto-save-data*
63              *functions-used*
64              *vble-declaration-done*))
65)
66
67(defvar *fortran-keywords*
68  '(assign if then go to goto call continue do fdo else elseif return
69    stop print read write backspace close endfile inquire
70    open rewind format and or not))
71
72
73
74(defun check_new_vbles (exprs)
75  (cond ((or (null exprs)
76             (numberp exprs)
77             (typep exprs 'string))
78         nil)
79        ((symbolp exprs)
80         (cond ((or (member exprs '(\, \' + - * / ** // ^ = equal > < >= <= >< |:|
81                                    /=
82                                    f2cl-//
83                                    %false% %true%
84                                    funcall))
85                    (member exprs *fortran-keywords*)
86                    (member exprs *key_params* :key #'car)
87                    (member exprs *external-function-names*)
88                    (member exprs *declared_vbles*)
89                    (member exprs *undeclared_vbles*)
90                    (sym-is-fun-name (list exprs))
91                    (sym-is-number-p exprs))
92                ;; This aren't new variables either because they can't
93                ;; be Fortran variables names or we've seen them
94                ;; already somewhere.
95                nil)
96               ((eq exprs 'pause)
97                )
98               (t
99                (pushnew (check-reserved-lisp-names exprs) *undeclared_vbles*))))
100        ((listp exprs)
101         (cond ((eq (first exprs) 'multiple-value-bind)
102                ;; Function calls get turned into a MULTIPLE-VALUE-BIND, so
103                ;; the only possible place for variables is the arg list for
104                ;; the function.
105                (mapc #'check_new_vbles (cdr (third exprs))))
106               ((eq (first exprs) 'array-slice)
107                ;; The only place for variables is the array name or
108                ;; the indices
109                (check_new_vbles (second exprs))
110                (mapc #'check_new_vbles (cdddr exprs)))
111               ((eq (first exprs) 'make-array)
112                ;;Nothing to do
113                )
114               ((cdr exprs)
115                ;; Have a function call.  Only need to look at the
116                ;; args for new variables
117                (mapc #'check_new_vbles (cdr exprs)))
118               (t
119                (mapc #'check_new_vbles exprs))))
120        (t
121         (error "What happened?")))
122  exprs)
123
124;; This takes a list of individual Lisp declarations and combines them
125;; into one based on the declared type.  Thus
126;;
127;;  (declare (type fixnum x))
128;;  (declare (type fixnum y))
129;;  (declare (type single-float z))
130;;
131;; becomes
132;;
133;;  (declare (type fixnum x y)
134;;           (type single-float z))
135(defun pretty-decls (decls)
136  (let ((type-hash (make-hash-table :test 'equal)))
137    (dolist (decl decls)
138      (destructuring-bind (dcl (type v-type var))
139          decl
140        (declare (ignore dcl type))
141        (let ((val (gethash v-type type-hash)))
142          (setf (gethash v-type type-hash)
143                (push var val)))))
144    (let ((dec '()))
145      (maphash #'(lambda (key val)
146                   (push `(type ,key ,@val) dec))
147               type-hash)
148      `((declare ,@dec)))))
149
150(defun lookup-vble-type (vble &optional (decls *explicit_vble_decls*))
151  ;;(format t "lookup-vble: ~a~%" vble)
152  (cond ((or (member vble *declared_vbles*)
153             (member vble *subprog-arglist*))
154         ;;(format t "  is declared var~%")
155         ;;(format t "  explicit_vbld_decls = ~A~%" *explicit_vble_decls*)
156         
157         ;; First for declared variables
158         (do* ((type-clauses decls
159                             (rest type-clauses))
160               (type (member vble (cdar type-clauses) :key #'car)
161                     (member vble (cdar type-clauses) :key #'car)))
162              ((or type
163                   (null type-clauses))
164               (let ((v-type (caar type-clauses)))
165                 (cond ((eq v-type 'array)
166                        ;; Hmm, this is probably an array declared
167                        ;; with a dimension statement, and either the
168                        ;; type is declared later or implicit typing
169                        ;; is used.
170                        ;;
171                        ;; Try to lookup the type again but skip over
172                        ;; array types.  If this works, the array type
173                        ;; was explicitly given so use it. Otherwise,
174                        ;; use Fortran typing rules.
175                        (cond ((lookup-vble-type vble (remove 'array decls :key #'first)))
176                              ((get-implicit-type vble))
177                              ((default-int-p vble)
178                               'integer4)
179                              (t (maybe-promote-type 'single-float))))
180                       ((and (listp v-type)
181                             (eq (first v-type) 'character))
182                        ;; Hmm, a Fortran character string.  Make it a Lisp string
183                        (if (numberp (second v-type))
184                            `(string ,(second v-type))
185                            'string))
186                       (t
187                        ;; If type is NIL, use implicit type
188                        (if (null v-type)
189                            (cond ((get-implicit-type vble))
190                                  ((default-int-p vble)
191                                   'integer4)
192                                  (t
193                                   (maybe-promote-type 'single-float)))
194                            v-type))))
195               ;;(format t  "type-clause = ~S~%" type-clauses)
196               )))
197        (t
198         ;;(format t "  is not declared. Implicit type = ~a~%" (get-implicit-type vble))
199         ;;(format t "implicit ~a~%" *implicit_vble_decls*)
200         (cond ((get-implicit-type vble))
201               ((default-int-p vble)
202                'integer4)
203               (t
204                (maybe-promote-type 'single-float))))))
205
206;; A simple implementation of Fortran contagion.
207;;
208;; Coerce 0 to the types T1 and T2 and add the result.  The type of
209;; the sum is the desired type.  However, we convert some of the types
210;; to ones that f2cl understands.
211(defun fortran-contagion (t1 t2)
212  (let ((sum (+ (coerce 0 t1) (coerce 0 t2))))
213    (typecase sum
214      ((complex double-float)
215       'complex16)
216      ((complex single-float)
217       'complex8)
218      (integer
219       'integer4)
220      (t
221       (type-of sum)))))
222
223(defun get-fun-arg-type (arg)
224  (cond ((symbolp arg)
225         (case arg
226           ((%false% %true%)
227            'logical)
228           (t
229            ;; Lookup the variable type and return it.
230            (let ((var-type (lookup-vble-type arg)))
231              (cond ((eq var-type 'array)
232                     ;; Look up the type of the array
233                     (destructuring-bind (&optional decl1 decl2)
234                         (vble-declared-twice-p arg *explicit_vble_decls*)
235                       (declare (ignorable decl2))
236                       (values (first decl1) t)))
237                    ((vble-is-array-p arg)
238                     (values var-type t))
239                    (t
240                     var-type)))
241            )))
242        ((listp arg)
243         ;; We have an expression of some type
244         (let ((fun (first arg)))
245           (cond ((eq 'make-array fun)
246                  ;; Some array slicing here.
247                  (values (second (second (member :element-type arg))) t))
248                 ((eq 'array-slice fun)
249                  (values (get-fun-arg-type (second arg)) t))
250                 ((eq 'funcall fun)
251                  ;; Look up function type
252                  (get-fun-arg-type (second arg)))
253                 ((eq 'fref fun)
254                  ;; Look up array references.
255                  (let ((result (get-fun-arg-type (second arg))))
256                    (values result nil)))
257                 ((member fun '(+ -))
258                  ;; Basic arithmetic operations that might be unary
259                  ;; operators.
260                  (if (third arg)
261                      (fortran-contagion (get-fun-arg-type (second arg))
262                                         (get-fun-arg-type (third arg)))
263                      (get-fun-arg-type (second arg))))
264                 ((member fun '(* f2cl/ expt))
265                  ;; Basic arithmetic operations.
266                  (fortran-contagion (get-fun-arg-type (second arg))
267                                     (get-fun-arg-type (third arg))))
268                 ((member fun '(conjg))
269                  ;; Complex conjugate
270                  (fortran-contagion (get-fun-arg-type (second arg))
271                                     'complex8))
272                 ((eq fun 'abs)
273                  ;; Absolute value
274                  (let ((arg-type (get-fun-arg-type (second arg))))
275                    (case arg-type
276                      (complex8
277                       'single-float)
278                      (complex16
279                       'double-float)
280                      (otherwise
281                       arg-type))))
282                 ((member fun '(cmplx))
283                  ;; Complex.  Figure out the type of complex we
284                  ;; should return.
285                  (fortran-contagion
286                   (fortran-contagion (get-fun-arg-type (second arg))
287                                      (get-fun-arg-type (third arg)))
288                   'complex8))
289                 ((member fun '(dcmplx))
290                  ;; double complex.  Always returns a complex16
291                  'complex16)
292                 ((member fun '(sin cos tan
293                                asin acos atan atan2
294                                sinh cosh tanh
295                                exp flog alog10 log10
296                                fsqrt aint sign dim max min))
297                  ;; Generic functions.  These generics always return
298                  ;; a number of the same type as its args.  Some
299                  ;; functions take more than one arg, but Fortran
300                  ;; says they are supposed to be the same type, so we
301                  ;; only need to look at the first.  Also, some of
302                  ;; them only take real-type arguments.  We don't
303                  ;; check for that because Fortran says you're
304                  ;; supposed to make sure they are anyway.
305                  (get-fun-arg-type (second arg)))
306                 ((member fun '(dsin dcos dtan
307                                dasin dacos datan datan2
308                                dexp dlog dlog10
309                                dabs dmax1 dmin1
310                                dble dimag
311                                dsqrt))
312                  ;; Double-precision functions
313                  'double-float)
314                 ((member fun '(csin ccos ctan
315                                casin cacos catan catan2
316                                cexp clog clog10
317                                cabs
318                                csqrt))
319                  ;; Complex functions
320                  'complex8)
321                 ((member fun '(zsin zcos ztan
322                                zasin zacos zatan zatan2
323                                zexp zlog zlog10
324                                zabs
325                                zsqrt))
326                  ;; Complex functions
327                  'complex16)
328                 ((member fun '(and or not > >= equal <= < logeqv logxor))
329                  ;; Logical operations
330                  'logical)
331                 ((eq fun 'multiple-value-bind)
332                  (get-fun-arg-type (third arg)))
333                 (t
334                  (get-fun-arg-type fun)))))
335        (t
336         ;; If we have a fixnum, return integer4 instead.
337         (if (typep arg 'integer)
338             'integer4
339             (type-of arg)))))
340
341(defun get-upgraded-fun-arg-type (args)
342  (let ((res '()))
343    ;;(format t "args = ~a~%" args)
344    (dolist (arg args
345             (nreverse res))
346      ;; Handle the simple cases, and then Run down the list and
347      ;; lookup the argument types of each.
348      (cond ((numberp arg)
349             (push (type-of arg) res))
350            ((symbolp arg)
351             (push (get-fun-arg-type arg) res))
352            ((and (listp arg)
353                  (eq 'fref (first arg)))
354             (push (get-fun-arg-type (second arg)) res))
355            ((and (listp arg)
356                  (listp (car arg))
357                  (eq 'multiple-value-bind (caar arg)))
358             ;; A call to a function.  Look up the type of the
359             ;; function, but be careful.  Sometimes it's (fun args)
360             ;; and sometimes it's (funcall fun args)
361             (let ((f (third (car arg))))
362               (push (get-fun-arg-type (if (eq (first f) 'funcall)
363                                           (second (third (car arg)))
364                                           (first f)))
365                                       res)))
366            (t
367             (let ((arg-types (mapcar #'get-fun-arg-type arg)))
368               (push (cond ((every #'(lambda (x)
369                                       (eq x (first arg-types)))
370                                   arg-types)
371                            ;; All items are the same, so that's our type.
372                            (first arg-types))
373                           (t
374                            ;; Some items are different, so we can't
375                            ;; really say. (Although I think Fortran
376                            ;; says they should all have been the
377                            ;; same.)
378                            `(or ,@arg-types)))
379                     res)))))))
380
381;; This needs to be reworked!
382(defun get-arg-decl (list-of-arglists)
383  (let (res)
384    ;; Given a list of arglists, we derive the type for each of the arglists.
385    (dolist (arglist list-of-arglists)
386      (push (mapcar #'(lambda (arg)
387                        ;; Literal strings (which are of type (string
388                        ;; <len>)) confuse the mapcar below, so change
389                        ;; them into just type 'string.
390                        (multiple-value-bind (type arrayp)
391                            (get-fun-arg-type arg)
392                          (cond (arrayp
393                                 (if (subtypep type 'string)
394                                     ;; An array of strings
395                                     (intern (concatenate 'string (symbol-name '#:array-strings)))
396                                     ;; Some other type of array
397                                     (intern (concatenate 'string (symbol-name '#:array-) (string type)))))
398                                ((subtypep type 'string)
399                                 'string)
400                                ((subtypep type 'integer4)
401                                 'integer4)
402                                (t
403                                 type))))
404                    arglist)
405            res))
406    ;; Now make a list of each of the types of the arguments
407    (let ((types
408           (mapcar #'(lambda (z)
409                       (if (atom z)
410                           z
411                           (let ((nodup (remove-duplicates z :test #'equalp)))
412                             (if (rest nodup)
413                                 `(or ,@nodup)
414                                 (first nodup)))))
415                   (reduce #'(lambda (x accum)
416                               (mapcar #'(lambda (a b)
417                                           (if (listp a)
418                                               (cons b a)
419                                               (list b a)))
420                                       x accum))
421                           res))))
422      ;; Remove an extra set of parens if needed.
423      (if (and (= (length types) 1) (listp (first types)))
424          (first types)
425          types))))
426
427;; Create declarations for all the functions used in the subprogram.
428;; We return three items: statement functions, other functions, and
429;; functions in the parameter list of the subprogram.
430(defun make-fcn-decl (fcn-list arglist)
431  (let (stmt-fcns other-fcns arg-fcns)
432    (dolist (fcn fcn-list)
433      (destructuring-bind ((fname &optional ftype) args)
434          fcn
435        ;;(format t "declaring fcn ~S~%" fcn)
436        ;;(format t "fname = ~A~%" fname)
437        ;;(format t "args = ~A~%" args)
438        (let* ((type (get-fun-arg-type fcn))
439               ;; If the function is an intrinsic, there is exactly
440               ;; one return value.  If it's not an intrinsic but it
441               ;; is a function, the return values are the function
442               ;; value and the list of arguments.  (This is how f2cl
443               ;; works).  If it's not an intrinsic and is a
444               ;; subroutine (ftype non-NIL), the return type is the
445               ;; list of arguments.  (Should we derive the type of
446               ;; these and put them in the values list?)
447               (decl `(function ,(get-arg-decl args)
448                       (values
449                        ,@(if ftype nil (list type))
450                        ,@(if (member fname *intrinsic-function-names*)
451                              nil
452                              '(&rest t))))))
453          ;;(format t "type = ~A~%" type)
454          ;;(format t "decl = ~A~%" decl)
455          ;;(format t "get-arg-decl = ~A~%" (get-arg-decl args))
456          (cond ((member fname *subprog-stmt-fns*)
457                 (push `(declare (ftype ,decl ,fname)) stmt-fcns))
458                ((member fname arglist)
459                 ;; What can we really do for a function that appears
460                 ;; in the arglist?  We don't really know anything
461                 ;; about it, so don't try to declare the function.
462                 
463                 ;;(format t "arglist fcn = ~A~%" `(declare (type ,decl ,fname)))
464                 #+nil
465                 (push `(declare (type ,decl ,fname)) arg-fcns))
466                ((member fname *intrinsic-function-names*)
467                 ;; We don't need declarations for intrinsic functions
468                 nil)
469                (t
470                 (push `(declare (ftype ,decl ,fname)) other-fcns))))))
471    (values stmt-fcns other-fcns arg-fcns)))
472
473;; Given the program list P, look through it and try to convert all
474;; occurrences of f2cl/ with either / or TRUNCATE.  We use TRUNCATE if
475;; both parameters are integers; / if both parameters are float or
476;; complex.  If we can't determine the types of the parameters, we
477;; leave it alone.
478;;
479;; A new tree with the (possibly) modified code is returned.
480;;
481;; This is an attempt to optimize out the calls to the f2cl/ macro.
482;; This is for the benefit of Lisp compilers that aren't smart enough
483;; to optimize unused parts of the macros out. (We should probably do
484;; a similar thing for sqrt, log, log10.)
485;;
486(defun optimize-f2cl/ (p)
487  (cond ((or (atom p) (null p))
488         p)
489        ((eq (first p) 'f2cl/)
490         ;; Let's try to optimize f2cl/ to either / or truncate
491         ;; appropriately.  If both parameters to f2cl/ are integers,
492         ;; we use truncate; if either parameter is a float or
493         ;; complex, use /.  If we can't determine the type, leave the
494         ;; macro in.
495
496         (let* ((left (get-fun-arg-type (list (second p))))
497                (right (get-fun-arg-type (list (third p))))
498                (fun (cond ((and (subtypep left 'integer)
499                                 (subtypep right 'integer))
500                            'truncate)
501                           ((or (subtypep left 'number)
502                                (subtypep right 'number))
503                            '/)
504                           (t
505                            'f2cl/))))
506           `(,fun ,@(mapcar #'optimize-f2cl/ (rest p)))))
507        (t
508         `(,(first p) ,@(mapcar #'optimize-f2cl/ (rest p))))))
509
510;; Given the program list P, look through it and try to convert all
511;; occurrences of integer arithmetic with the integer arithmetic
512;; macros.  This is done so that integer arithmetic doesn't have to
513;; check for possible overflow because that behavior is undefined in
514;; Fortran anyway.
515;;
516;; A new tree is returned.
517(defun optimize-integer-arithmetic (p)
518  (cond ((or (atom p) (null p))
519         p)
520        ((eq (first p) 'declare)
521         ;; Skip over declarations
522         p)
523        ((eq (first p) 'quote)
524         ;; Skip over quoted objects
525         p)
526        ((eq (first p) 'fdo)
527         ;; FDO handled specially
528         (destructuring-bind (fdo (var1 init step-form)
529                                  ((cmp-fun var2 end-form) ret-form)
530                                  &rest body)
531             p
532         `(,fdo (,var1 ,(optimize-integer-arithmetic init)
533                      ,(optimize-integer-arithmetic step-form))
534               ((,cmp-fun ,var2 ,(optimize-integer-arithmetic end-form))
535                ,ret-form)
536           ,@(mapcar #'optimize-integer-arithmetic body))))
537        ((eq (first p) 'fref)
538         ;; FREF handled specially
539         (destructuring-bind (fref data-var indices bounds &rest offset)
540             p
541           `(,fref ,data-var ,(mapcar #'optimize-integer-arithmetic indices)
542                             ,(mapcar #'optimize-integer-arithmetic bounds)
543                             ,@offset)))
544        ((member (first p) '(min max))
545         ;; We might need to do something here because CMUCL doesn't
546         ;; always know how to optimize this right.
547         (let* ((int-args-p
548                 (every #'(lambda (e)
549                            (eq e 'integer4))
550                        (mapcar #'(lambda (arg)
551                                    (let ((res (get-fun-arg-type (list arg))))
552                                      ;;(format t "arg = type ~A: ~A~%" res arg)
553                                      res))
554                                (rest p))))
555                (opt-args
556                 (mapcar #'optimize-integer-arithmetic (rest p))))
557           ;;(format t "min/max opt. int-args-p = ~A~%" int-args-p)
558           ;;(format t "args = ~A~%" (rest p))
559           ;;(format t "opt-args = ~A~%" opt-args)
560           (if int-args-p
561               `(,(first p) ,@(mapcar #'(lambda (x)
562                                          `(the integer4 ,x))
563                                      opt-args))
564               `(,(first p) ,@opt-args))))
565        ((eq (first p) 'truncate)
566         ;; Hmm, make sure truncate returns a integer4
567         `(the integer4 ,p))
568        ((and (member (first p) '(+ - *))
569              (rest p))
570         ;; Basic arithmetic operations.  Division has already been
571         ;; handled by converting / to f2cl/ which is optimized
572         ;; somewhere else.
573         
574         ;;(format t "expr = ~A~%" p)
575         (let ((fun (if (every #'(lambda (e)
576                                   (eq e 'integer4))
577                               (mapcar #'(lambda (arg)
578                                           (let ((res (get-fun-arg-type arg)))
579                                             ;;(format t "arg = type ~A: ~A~%" res arg)
580                                             res))
581                                       (rest p)))
582                        (cdr (assoc (first p) '((+ . int-add)
583                                                (- . int-sub)
584                                                (* . int-mul))))
585                        (first p))))
586           `(,fun ,@(mapcar #'optimize-integer-arithmetic (rest p)))))
587        ((listp (first p))
588         `(,(mapcar #'optimize-integer-arithmetic
589                     (first p))
590           ,@(mapcar #'optimize-integer-arithmetic (rest p))))
591        (t
592         `(,(first p) ,@(mapcar #'optimize-integer-arithmetic (rest p))))))
593 
594;; Given the program list P, look through it and try to convert all
595;; occurrences of external functions with #'<func>.  Do this only if
596;; the function is not first element of a list.
597;;
598;; A new tree with the (possibly) modified code is returned.
599;;
600(defun fixup-external-function-refs (p externs)
601  (cond ((null p)
602         p)
603        ((atom p)
604         (if (member p externs)
605             `(function ,p)
606             p))
607        ((eq (first p) 'declare)
608         ;; Skip over declarations
609         p)
610        ((eq (first p) 'function)
611         ;; Skip over functions that we have already done
612         p)
613        ((eq (first p) 'funcall)
614         ;; Skip over funcalls!
615         `(,(first p) ,(second p) ,@(mapcar #'(lambda (pp)
616                                                (fixup-external-function-refs pp externs))
617                                            (cddr p))))
618        (t
619         `(,(first p) ,@(mapcar #'(lambda (pp)
620                                    (fixup-external-function-refs pp externs))
621                                (rest p))))))
622
623;; In the following functions, we are trying to simplify some of the
624;; expressions produced by f2cl.  We should probably use some real
625;; pattern matching algorithm instead of these hand-written matchers.
626;;
627;; Fix up the expression by destructively modifying it. This tries to
628;; convert some expressions produced by f2cl into something more
629;; readable:
630
631;; f2cl always converts (- X) to (* -1 X).  This function tries to
632;; undo that.  A new tree is returned with the result.
633(defun fixup-expr-mul (expr)
634  (cond ((or (atom expr) (null expr))
635         expr)
636        ((and (eq (first expr) '*)
637              (numberp (second expr))
638              (= (second expr) -1))
639         ;; Convert (* -1 X) to (- X)
640         `(- ,@(fixup-expr-mul (rest (rest expr)))))
641        (t
642         `(,(first expr) ,@(mapcar #'fixup-expr-mul (rest expr))))))
643
644;; We try to handle some conversions that make the resulting
645;; expressions a bit easier to read and more natural.  Also, some of
646;; the transformations reduce the number of operations needed.  (These
647;; may not be needed if the compiler is smart enough.)
648;;
649;; F2CL                            RESULT
650;; (- N)                           -N        (for numeric N)
651;; (+ (- Z) X)                     (- X Z)
652;; (op (- Z) X)                    (op -Z X) (for number N, and any function F, except +
653;; (+ X (- Z))                     (- X Z)
654;; (F X (- Z))                     (F X -Z)  (for F /= + and Z a number)
655;; (+ X (op (- Z) Y))              (- X (op Z Y))  (for op = * or /)
656(defun fixup-expression (expr)
657  (flet ((is-neg (e)
658           ;; Return T if the e looks something like '(- Z)
659           (and (listp e)
660                (eq (first e) '-)
661                (= (length e) 2))))
662    (cond ((or (atom expr) (null expr))
663           expr)
664          ((eq (first expr) 'fref)
665           ;; Fixup the expressions for the index.
666           ;;(format t "expr = ~S: ~S~%" expr (mapcar #'fixup-expression (third expr)))
667           `(fref ,(second expr)
668             ,(mapcar #'fixup-expression (third expr))
669             ,@(if (fourth expr)
670                   (list (fourth expr)))))
671          ((eq (first expr) 'fdo)
672           ;; Handle fdo: the fdo macro depends on a certain format
673           ;; for the loop (yuck!  Need to change that!)
674           `(fdo ,(second expr) ,(third expr) ,@(mapcar #'fixup-expression (nthcdr 3 expr))))
675          ((and (eq (first expr) '-)
676                (numberp (second expr)))
677           ;; Convert (- N) to just -N
678           (- (second expr)))
679          ((is-neg (second expr))
680           ;; We have (F (- Z) X ...).  If F is '+,
681           ;; make it (- X Z).  If Z is a number, make it (F -Z X ...)
682           (cond ((eq (first expr) '+)
683                  ;; (+ (- Z) X ...) => (- X Z)
684                  `(- ,@(mapcar #'fixup-expression (rest (rest expr)))
685                      ,@(mapcar #'fixup-expression (rest (second expr)))))
686                 ((numberp (second (second expr)))
687                  `(,(first expr) ,(- (second (second expr)))
688                    ,@(mapcar #'fixup-expression (rest (rest expr)))))
689                 (t
690                  `(,@(mapcar #'fixup-expression expr)))))
691          ((is-neg (third expr))
692           ;; We have (F X (- Z) ...).  If F is '+, convert to (- X Z).
693           ;; If not, but Z is a number, convert to (F X -Z ...).
694           (cond ((eq '+ (first expr))
695                  ;; We have '(+ X (- Z)).  Make that '(- X Z)
696                  `(- ,@(mapcar #'fixup-expression (list (second expr)))
697                      ,@(mapcar #'fixup-expression (list (second (third expr))))))
698                 ((numberp (second (third expr)))
699                  ;; We have (F X (- N) ...).  Make that (F X -N ...)
700                  `(,(first expr) ,@(mapcar #'fixup-expression (list (second expr)))
701                                  ,(- (second (third expr)))
702                                  ,@(mapcar #'fixup-expression (nthcdr 3 expr))))
703                 (t
704                  ;; Process the X and (- Z) parts now
705                  ;;(format t "T case (F X (- Z) ...): ~S~%" expr)
706                  `(,(first expr) ,(fixup-expression (second expr))
707                                  ,@(mapcar #'fixup-expression (rest (rest expr)))))))
708          ((and (eq (first expr) '+)
709                (listp (third expr))
710                (member (first (third expr)) '(* /))
711                (listp (second (third expr)))
712                (eq (first (second (third expr))) '-))
713           ;; We have (+ X (op (- Z) Y)).  Convert to (- X (op Z Y)), for op = * or /.
714
715           ;;(format t "got ~S~%" expr)
716           `(- ,(fixup-expression (second expr))
717             (,(first (third expr))
718              ,@(mapcar #'fixup-expression (rest (second (third expr))))
719              ,@(mapcar #'fixup-expression (rest (rest (third expr)))))))
720          (t
721           ;; Didn't match, so descend into the remaining args
722           `(,(first expr) ,@(mapcar #'fixup-expression (rest expr)))))))
723
724(defun fixup-relop (expr)
725  (cond ((or (null expr)
726             (atom expr)
727             (typep expr 'string))
728         expr)
729        ((member (first expr) '(|>=| |<=| equal |/=| < > =))
730         ;; If one arguments is a string, replace operation with the
731         ;; appropriate string operation.
732         (let ((lhs (get-fun-arg-type (list (second expr))))
733               (rhs (get-fun-arg-type (list (third expr)))))
734           (cond ((or (subtypep lhs 'string)
735                      (subtypep rhs 'string))
736                  (let ((op (intern (concatenate 'string
737                                                 (symbol-name '#:fstring-)
738                                                 (symbol-name (first expr))))))
739                    `(,op ,(second expr) ,(third expr))))
740                 (t
741                  expr))))
742        (t
743         `(,@(mapcar #'fixup-relop expr)))))
744
745(defun merge-ops (expr)
746  (cond ((or (null expr)
747             (atom expr)
748             (typep expr 'string))
749         expr)
750        ((and (third expr)
751              (member (first expr) '(+ * - /)))
752         ;; Try to merge a bunch of +, *, -, / operations into one.
753         (destructuring-bind (op next &rest args)
754             expr
755           ;;(setf args (list args))
756           (when (and (listp next) (third next))
757             (loop while (and (listp next) (eq op (first next)))
758               do
759               (push (third next) args)
760               (setf next (second next))))
761           `(,op ,(merge-ops next) ,@(merge-ops args))))
762        (t
763         `(,@(mapcar #'merge-ops expr)))))
764         
765
766(defun find-sym (sym code)
767  (cond ((atom code)
768         (eq sym code))
769        ((null code)
770         nil)
771        (t
772         (or (find-sym sym (car code))
773             (find-sym sym (cdr code))))))
774
775(defun remove-unused-sym-macros (sym-mlets sym-lets prog-bit)
776  #+(or)
777  (progn
778    (format t "sym-mlets = ~S~%" sym-mlets)
779    (format t "sym-lets  = ~S~%" sym-lets)
780    (format t "prog =~%~S~%" prog-bit))
781  (let ((new-sym-mlets nil)
782        (new-sym-lets nil))
783    ;; For each symbol in sym-mlets, look to see if it is used in
784    ;; prog-bit.  If so, keep it.
785    (dolist (mlet sym-mlets)
786      (let ((sym (car mlet)))
787        (when (find-sym sym prog-bit)
788          (push mlet new-sym-mlets))))
789    (setf new-sym-mlets (nreverse new-sym-mlets))
790    ;;(format t "new-sym-mlets = ~S~%" new-sym-mlets)
791    ;; Look through sym-lets for things that match our new symbol
792    ;; macros.  Save the matches, discarding the rest.
793    (dolist (mlet new-sym-mlets)
794      (when (atom (second mlet))
795        (let ((item (find (second mlet) sym-lets :key #'first)))
796          (push item new-sym-lets))))
797    (setf new-sym-lets (nreverse new-sym-lets))
798    ;;(format t "new-sym-lets = ~S~%" new-sym-lets)
799    (values new-sym-mlets new-sym-lets)))
800
801(defun remove-unused-key-params (keys code)
802  (let ((used-keys nil))
803    (dolist (key keys)
804      (let ((keyname (first key)))
805        ;; If the key is used in other keys, we need to keep it.
806        ;; Otherwise, look throught the code to see if the key is
807        ;; used.  If so, keep it too.
808        (if (find-if #'(lambda (k)
809                         (if (atom k)
810                             (eq keyname k)
811                             (member keyname k)))
812                     keys :key #'second)
813            (push key used-keys)
814            (when (find-sym keyname code)
815              (push key used-keys)))))
816    (setf used-keys (nreverse used-keys))
817    (values used-keys)))
818
819
820(defun create-sym-macros (prog-bit)
821  (let ((sym-mlets '())
822        (sym-lets ()))
823    (if *common-blocks-as-arrays*
824        (let ((common-var-decls (mapcar #'make-special-var-decl *subprog_common_vars*)))
825          (setf common-var-decls (append '(declaim)
826                                         (mapcar #'(lambda (decl)
827                                                     (second decl))
828                                                 common-var-decls)))
829          (multiple-value-setq (sym-mlets sym-lets)
830            (create-sym-macros-array common-var-decls)))
831        (maphash
832         #'(lambda (key varlist)
833             (mapc #'(lambda (var)
834                       (let ((accessor-name
835                              (intern (concatenate 'string
836                                                   (symbol-name key)
837                                                   "-"
838                                                   (symbol-name var))))
839                             (name
840                              (intern (concatenate 'string
841                                                   "*"
842                                                   (symbol-name key)
843                                                   (symbol-name '#:-common-block*)))))
844                         (if (vble-is-array-p var)
845                             (progn
846                               (push `(,accessor-name (,accessor-name ,name)) sym-lets)
847                               (push `(,var ,accessor-name) sym-mlets))
848                             (push `(,var (,accessor-name ,name)) sym-mlets))
849                         ))
850                   varlist))
851         *common-blocks*))
852    (multiple-value-bind (new-sym-mlets new-sym-lets)
853        (remove-unused-sym-macros sym-mlets sym-lets prog-bit)
854      (values new-sym-mlets new-sym-lets))))
855
856(defun create-sym-macros-array (common_var_decls)
857  (let ((sym-mlets '())
858        (sym-lets ()))
859    (labels
860        ((create (key v var-type part posn len arrayp)
861           #+nil
862           (format t "var = ~A :type ~A Part ~A posn ~A~%"
863                   v var-type part posn)
864           (let ((accessor-name
865                  (intern (format nil "~A-~A" key v)))
866                 (name
867                  (intern (format nil "*~A-COMMON-BLOCK*" key)))
868                 (part-name (intern (format nil "~A-PART-~D" key part))))
869             (if arrayp
870                 (progn
871                   (push `(,accessor-name
872                           (make-array ,len :element-type ',(second var-type)
873                                       :displaced-to (,part-name ,name)
874                                       :displaced-index-offset ,posn))
875                         sym-lets)
876                   (push `(,v ,accessor-name) sym-mlets))
877                 (push `(,v (aref (,part-name ,name) ,posn))
878                       sym-mlets))))
879         (process-block (key varlist)
880           (let ((part 0)
881                 (prev-type nil)
882                 (total-len 0)
883                 (posn 0))
884             (dolist (v varlist)
885               (let* ((decl (find v (rest common_var_decls) :key #'third))
886                      (var-type (if decl (second decl) nil))
887                      (el-type (if (subtypep var-type 'array)
888                                   (second var-type)
889                                   var-type)))
890                 (unless prev-type
891                   (setf prev-type el-type))
892                 (multiple-value-bind (len arrayp)
893                     (if (subtypep var-type 'array)
894                         (values (first (third var-type)) t)
895                         (values 1 nil))
896                   (unless (and (subtypep el-type prev-type)
897                                (subtypep prev-type el-type))
898                     (setf prev-type el-type)
899                     (incf part)
900                     (setf total-len 0)
901                     (setf posn 0))
902                       
903                   (create key v var-type part posn len arrayp)
904                   (incf total-len len)
905                   (incf posn len)))))))
906      (maphash #'process-block *common-blocks*)
907      (setf sym-mlets (nreverse sym-mlets))
908      (setf sym-lets (nreverse sym-lets))
909      ;;(format t "sym-mlets = ~S~%" sym-mlets)
910      ;;(format t "sym-lets  = ~S~%" sym-lets)
911      (values sym-mlets sym-lets))))
912
913(defun coerce-parameter-assign (lhs rhs)
914  (let* ((lhs-type (first (get-upgraded-fun-arg-type (list (list lhs)))))
915         (rhs-type (first (get-upgraded-fun-arg-type (list (list rhs))))))
916    ;;(format t "~&")
917    ;;(format t "lhs = ~A, type ~A~%" lhs lhs-type)
918    ;;(format t "rhs = ~A, type ~A~%" rhs rhs-type)
919    (cond ((subtypep lhs-type 'string)
920           (warn "Assignment of string in parameter statements may not be right.")
921           rhs)
922          (t
923           (let ((new-rhs
924                  (cond ((find *coerce-assignments* '(t :always))
925                         `(coerce ,rhs (type-of ,lhs)))
926                        ((find *coerce-assignments* '(nil :never))
927                         rhs)
928                        (t
929                         ;;(format t "rhs-type, rhs = ~S ~S~%" rhs-type rhs)
930                         ;; RHS.  Otherwise, coerce the RHS to the
931                         ;; type of the LHS.  However, we can't coerce
932                         ;; something to an integer.  Use truncate for
933                         ;; that.
934                         (cond ((or (eq t rhs-type)
935                                    (eq t lhs-type)
936                                    (subtypep rhs-type lhs-type))
937                                ;; No coercion is needed if the types
938                                ;; match, or if we can't determine the
939                                ;; type of the LHS or RHS.
940                                rhs)
941                               ((and (subtypep lhs-type 'integer)
942                                     (not (subtypep rhs-type 'integer)))
943                                ;; We're trying to set a integer
944                                ;; variable to non-integer value.  Use
945                                ;; truncate.
946                                `(int ,rhs))
947                               (t
948                                ;; Haven't a clue, so coerce
949                                `(coerce ,rhs ',lhs-type)))))))
950             new-rhs)))))
951
952(defun flatten-list (x)
953  (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
954             (cond ((null x) r)
955                   ((atom x)
956                    (cons x r))
957                   (t (flatten-helper (car x)
958                                      (flatten-helper (cdr x) r))))))
959    (flatten-helper x nil)))
960
961#+nil
962(defun entry-functions (entry main args)
963  (flet ((make-vars (n)
964           (let ((v '()))
965             (dotimes (k n)
966               (push (intern (format nil "V~D" k)) v))
967             (nreverse v)))
968         (select-vars (k n vlist)
969           (append (list (elt vlist k))
970                   (subseq vlist n)))
971         (make-ignore (k n vlist)
972           (append (subseq vlist 0 k)
973                   (subseq vlist (1+ k) n)))
974           )
975    (let* ((count 0)
976           (n-entries (1+ (length *entry-points*)))
977           (n-returns (+ n-entries (length args)))
978           (vlist (make-vars n-returns)))
979      (cons `(defun ,main ,args
980              (multiple-value-bind ,vlist
981                  (,entry ',main ,@args)
982                (declare (ignore ,@(make-ignore 0 n-entries vlist)))
983                (values ,@(select-vars 0 n-entries vlist))))
984            (mapcar #'(lambda (x)
985                        (let ((vlist (make-vars n-returns)))
986                          (incf count)
987                          `(defun ,(first x) ,@(rest x)
988                            (multiple-value-bind ,vlist
989                                (,entry ',(first x) ,@(second x))
990                              (declare (ignore ,@(make-ignore count n-entries vlist)))
991                              (values ,@(select-vars count n-entries vlist))))
992                          ))
993                    *entry-points*)))))
994
995(defun entry-functions (entry main args)
996  (flet ((make-vars (n)
997           (let ((v '()))
998             (dotimes (k n)
999               (push (intern (format nil "V~D" k)) v))
1000             (nreverse v)))
1001         #+nil
1002         (make-ignore (k n vlist)
1003           (append (subseq vlist 0 k)
1004                   (subseq vlist (1+ k) n)))
1005           )
1006    (let* ((count 0)
1007           (n-returns (length args))
1008           (vlist (make-vars n-returns)))
1009      (cons `(defun ,main ,args
1010              (multiple-value-bind ,vlist
1011                  (,entry ',main ,@args)
1012                (values ,@vlist)))
1013            (mapcar #'(lambda (x)
1014                        (let ((vlist (make-vars n-returns)))
1015                          (incf count)
1016                          `(defun ,(first x) ,@(butlast (rest x))
1017                            (multiple-value-bind ,vlist
1018                                (,entry ',(first x) ,@(second x))
1019                              (values ,@vlist)))))
1020                    *entry-points*)))))
1021
1022
1023(defvar *enable-merging-data-and-save-init* t)
1024
1025;; This is kind of experimental (and a very, very gross
1026;; implementation!).  What we're trying to do is move all of the data
1027;; initialization statements for arrays (from DATA statements) into
1028;; the initialization of the variable itself.  This makes the code
1029;; look like more idiomatic Lisp and it seems to help out compilers
1030;; quite a bit.
1031(defun merge-data-and-save-inits (saves data)
1032  (labels ((find-inits (name)
1033             ;; Look through the data init statements to find an array
1034             ;; initializer for our specified variable NAME.  The
1035             ;; initializer will look something like (FSET (FREF VAR
1036             ;; index limits) value).  Return a list of all matches as
1037             ;; the first value.  The scond value indicates if this is a
1038             ;; 1D array.
1039             (let ((inits '())
1040                   (1d-array-p t))
1041               (dolist (item data)
1042                 ;; FIXME: This critically depends on FSET being used
1043                 ;; to initialize the values for DATA statements.  If
1044                 ;; this is changed, we need to change this!  (Gross!)
1045                 (when (eq 'fset (first item))
1046                   (destructuring-bind (fset (fref var-name indices &rest dims) value)
1047                       item
1048                     (declare (ignore fset fref dims value))
1049                     (when (and (eq var-name name))
1050                       (push item inits)
1051                       (unless (= 1 (length indices))
1052                         (setf 1d-array-p nil))))))
1053               (values (nreverse inits) 1d-array-p)))
1054           (col-major-index (indices limits)
1055             ;; Compute the column major index given the set of
1056             ;; indices and bounds.  Given indicies (i1 i2 ... in) and
1057             ;; limits ((l1 h1) (l2 h2) ... (ln hn)), the colum-major
1058             ;; index as used by Fortran would be
1059             ;;
1060             ;; (i1 - l1) +
1061             ;;   (h1-l1+1)*((i2 - l2) +
1062             ;;                (h2-l2+1)*((i3 - l3) +
1063             ;;                             (h3 - l3 + 1) * ...)))
1064             ;;
1065             ;; See col-major-index in macros.l too.
1066             (if (null indices)
1067                 0
1068                 (destructuring-bind (lo hi)
1069                     (car limits)
1070                   (+ (- (car indices)
1071                         lo)
1072                      (* (1+ (- hi lo))
1073                         (col-major-index (rest indices) (rest limits)))))))
1074           (find-array-dims (dims)
1075             ;; If the dimensions are numbers return them.  If they're
1076             ;; not, we could look in the parameter variables to see
1077             ;; if we can figure it out.  Return NIL if we can't
1078             ;; figure out the dimensions.
1079             (cond ((listp dims)
1080                    ;; Must be of the form (quote (a ...)).  Strip of quote
1081                    (when (every #'integerp (cdr dims))
1082                      dims))
1083                   ((integerp dims)
1084                    dims)
1085                   (t
1086                    nil))))
1087         
1088    (let ((new-saves '())
1089          (new-data '())
1090          (array-element-inits '()))
1091      ;; First, save all non-array data initializers.
1092      (dolist (item data)
1093        ;;(format t "data item = ~S~%" item)
1094        (if (eq 'fset (first item))
1095            (push (cdr item) array-element-inits)
1096            (push item new-data)))
1097      #+nil
1098      (progn
1099        (format t "new-data = ~A~%" new-data)
1100        (format t "array-element-inits = ~A~%" array-element-inits))
1101      ;; Now look through all the saved vars
1102      (dolist (item saves)
1103        ;;(format t "save item = ~S~%" item)
1104        (cond ((and (listp (second item))
1105                    (eq 'make-array (first (second item))))
1106               ;; Got an array.  Look for initializers in DATA.
1107               (let ((type (second (fourth (second item))))
1108                     (inits (find-inits (first item)))
1109                     (array-dims (find-array-dims (second (second item)))))
1110                 #+nil
1111                 (progn
1112                   (format t "~D inits for ~S: ~S~%" (length inits) (first item) inits)
1113                   (format t "dims = ~S: ~A~%" (second (second item))
1114                           array-dims))
1115                 (cond ((and inits array-dims)
1116                        (let ((init (make-array array-dims
1117                                                :element-type type
1118                                                :initial-element
1119                                                (if (subtypep type 'character)
1120                                                    #\space
1121                                                    (coerce 0 type)))))
1122                          ;; Gather up the values into an array to be
1123                          ;; used for initializing the variable.  The
1124                          ;; array is initialized to zero (of the
1125                          ;; appropriate type).  If the original code
1126                          ;; didn't initialize it, then it didn't
1127                          ;; care.
1128                          (dolist (i inits)
1129                            (destructuring-bind (fset (fref var indices limits) val)
1130                                i
1131                              (declare (ignore fset fref var))
1132                              (setf (aref init (col-major-index indices limits))
1133                                    val)))
1134                          (push (list (car item)
1135                                      (append (copy-list (second item))
1136                                              `(:initial-contents ',(coerce init 'list))))
1137                                new-saves))
1138                        ;; Remove these from array-element-inits
1139                        (let ((array-name (first item)))
1140                          (setf array-element-inits
1141                                (remove array-name
1142                                        array-element-inits
1143                                        :key #'cadar))))
1144                       (t
1145                        ;; Save it as is.
1146                        (push item new-saves)))))
1147              ((and (listp (second item))
1148                    (eq 'f2cl-init-string (first (second item)))
1149                    (not (fourth (second item))))
1150               ;; We have something like
1151               ;;
1152               ;; (<var> (f2cl-init-string (<dims>) (<stringlen>) <inits>))
1153               ;;
1154               ;; Initializing an array of strings, but only if the
1155               ;; initializer isn't already given.  We don't do
1156               ;; anything special right now.
1157               (let ((inits (find-inits (first item))))
1158                 #+nil
1159                 (progn
1160                   (format t "inits for ~S: ~S~%" (first item) inits)
1161                   (format t "dims = ~S: ~A~%" (second (second item))
1162                           (reduce #'* (second (second item)))))
1163                 (cond
1164                   (inits
1165                    (let ((init (make-array (length inits)
1166                                            :initial-element
1167                                            (make-string (car (third (second item)))))))
1168                      ;; Gather up the values into an array to be
1169                      ;; used for initializing the variable.  The
1170                      ;; array is initialized to zero (of the
1171                      ;; appropriate type).  If the original code
1172                      ;; didn't initialize it, then it didn't
1173                      ;; care.
1174                      (dolist (i inits)
1175                        (destructuring-bind (fset (fref var indices limits) val)
1176                            i
1177                          (declare (ignore fset fref var))
1178                          (setf (aref init (col-major-index indices limits))
1179                                val)))
1180                      (push (list (car item)
1181                                  (append (butlast (copy-list (second item)))
1182                                          (list (coerce init 'list))))
1183                            new-saves))
1184                    ;; Remove these from array-element-inits
1185                    (let ((array-name (first item)))
1186                      (setf array-element-inits
1187                            (remove array-name
1188                                    array-element-inits
1189                                    :key #'cadar))))
1190                   (t
1191                    (push item new-saves)))))
1192              (t
1193               ;; Not an array
1194               (push item new-saves))))
1195      (cond (array-element-inits
1196             (warn "Bug in f2cl:  ~D array element initializers still left:~% ~S~%Merging not done."
1197                   (length array-element-inits) array-element-inits)
1198             (values saves data))
1199            (t
1200             (values (append (nreverse new-saves)
1201                             (nreverse array-element-inits))
1202                     (nreverse new-data)))))))
1203
1204(defun verify-and-generate-equivalences ()
1205  ;; Look over equivalences and see if we can handle them.  Right now,
1206  ;; we can only handle equivalences of the form (array, simple) or
1207  ;; (simple, array), and they must have the same type.
1208  ;;
1209  ;; So, if we have something like (x, y(4)), we can use a
1210  ;; symbol-macrolet to make x equivalent to y(4).
1211  (flet ((verify-types (array b)
1212           #+nil
1213           (progn
1214             (format t "Type of array: ~A = ~A (~A)~%" array (lookup-vble-type array)
1215                     (vble-is-array-p array))
1216             (format t "Type of a: ~A = ~A~%" b (lookup-vble-type b))
1217             (format t "explicit-vars = ~A~%" *explicit_vble_decls*)
1218             (format t "*declared_vbles* = ~A~%" *declared_vbles*))
1219           (assert (vble-is-array-p array))
1220           (let ((a-type (lookup-vble-type array))
1221                 (b-type (lookup-vble-type b)))
1222             (unless (eq a-type b-type)
1223               (error "f2cl cannot equivalence variables of different types: ~A (~A) and ~A (~A)"
1224                      array a-type b b-type))))
1225         (gen-fref (a)
1226           a))
1227    (let (res simple)
1228      (dolist (equiv *equivalenced-vars*)
1229        (cond ((and (symbolp (first equiv))
1230                    (symbolp (second equiv)))
1231               ;; Equivalence of two simple vars.  Just make one a
1232               ;; symbol-macrolet of the other, if the types match.
1233               (let ((a-type (lookup-vble-type (first equiv)))
1234                     (b-type (lookup-vble-type (second equiv))))
1235                 (unless (eq a-type b-type)
1236                   (error "f2cl cannot equivalence variables of different types: ~A (~A) and ~A (~A)"
1237                          (first equiv) a-type (second equiv) b-type))
1238                 (push (first equiv) simple)
1239                 (push `(,(first equiv) ,(second equiv)) res)))
1240              ((and (symbolp (first equiv))
1241                    (listp (second equiv))
1242                    (eq (car (second equiv)) 'fref))
1243               ;; (simple, array)
1244               ;; We want (symbol-macrolet (simple expansion))
1245               (verify-types (second (second equiv)) (first equiv))
1246               (push `(,(first equiv) ,(gen-fref (second equiv))) res)
1247               (push (first equiv) simple))
1248              ((and (symbolp (second equiv))
1249                    (listp (first equiv))
1250                    (eq (car (first equiv)) 'fref))
1251               ;; (array, simple)
1252               (verify-types (second (first equiv)) (second equiv))
1253               (push `(,(second equiv) ,(gen-fref (first equiv))) res)
1254               (push (second equiv) simple))
1255              (t
1256               (format t "~S~%" (first equiv))
1257               (format t "~S~%" (second equiv))
1258               (error "f2cl cannot handle EQUIVALENCE of ~A and ~A~%"
1259                      (first equiv) (second equiv)))))
1260      (values (nreverse res) (nreverse simple)))))
1261
1262(defun get-var-types (arglist &key declare-vars)
1263  "Compute the types of each variable in ARGLIST and also an
1264  appropriate declaration for each variable, if DECLARE-VARS is
1265  non-NIL."
1266  (let ((var-decls nil)
1267        (var-type-list nil))
1268    (dolist (vble arglist)
1269      (if (or (member vble *external-function-names*)
1270              (member vble *functions-used*
1271                      :key #'caar))
1272          (push t var-type-list)
1273        (let ((decl (make-declaration vble :vble-is-formal-arg t)))
1274          (destructuring-bind (declare-sym (type-sym type var))
1275              decl
1276            (declare (ignore declare-sym type-sym var))
1277            (when declare-vars
1278              (push decl var-decls))
1279            (setf *declared_vbles*
1280                  (remove vble *declared_vbles*))
1281            (setf *undeclared_vbles*
1282                  (remove vble *undeclared_vbles*))
1283            (push type var-type-list)))))
1284    (values (nreverse var-type-list)
1285            (nreverse var-decls))))
1286
1287(defun make-key-param-decls (keys)
1288  (let ((code-key-params-decls
1289         (mapcar #'(lambda (param)
1290                     (destructuring-bind (v val)
1291                         param
1292                       (make-declaration v :parameterp (if (numberp val) val nil))))
1293                 keys)))
1294
1295    (setf code-key-params-decls
1296          `((declare ,@(mapcan #'cdr code-key-params-decls)
1297                     (ignorable ,@(mapcar #'car keys)))))
1298    code-key-params-decls))
1299
1300(defun insert-declarations (fort-fun)
1301  (prog (defun-bit arglist prog-bit formal-arg-decls common_var_decls
1302                   local-vbles vble-decls body common-blocks
1303                   saved-decls save-inits
1304                   other-fcn-decls
1305                   stmt-fcn-decls
1306                   arg-fcn-decls
1307                   common-block-structs
1308                   key-params
1309                   key-params-decls
1310                   code-key-params
1311                   code-key-params-decls
1312                   all-decls
1313                   #+nil additional-args
1314                   entry-points equivalences)
1315
1316     (setq defun-bit (list (car fort-fun) (cadr fort-fun))
1317           arglist (caddr fort-fun)
1318           body (cdddr fort-fun))
1319     (setq *undeclared_vbles*
1320           (set-difference *undeclared_vbles* *subprog_common_vars*))
1321     (when (member :insert-declaration *f2cl-trace*)
1322       (format t "~&")
1323       (format t "declared_vbles   = ~S~%" *declared_vbles*)
1324       (format t "undeclared_vbles = ~S~%" *undeclared_vbles*)
1325       (format t "implicit_vbles   = ~S~%" *implicit_vble_decls*)
1326       (format t "*functions used* = ~S~%" *functions-used*)
1327       (format t "external func    = ~S~%" *external-function-names*)
1328       (format t "*subprog_common_vars* = ~S~%" *subprog_common_vars*)
1329       (format t "*common_array_dims*   = ~S~%" *common_array_dims*)
1330       (format t "*explicit_vble_decls* = ~A~%" *explicit_vble_decls*)
1331       (maphash #'(lambda (key val)
1332                    (format t "~A => ~A~%" key val))
1333                *common-blocks*))
1334     ;;(setq special-proclamation (make-special-proclamation *subprog_common_vars*))
1335     #+nil
1336     (when (member :insert-declaration *f2cl-trace*)
1337       (format t "special-proclamation = ~a~%" special-proclamation))
1338     (setq common_var_decls
1339           (mapcar #'make-special-var-decl *subprog_common_vars*))
1340     ;; Clean up the declarations by merging them into one
1341     (setq common_var_decls
1342           (append '(declaim)
1343                   (mapcar #'(lambda (decl)
1344                               (second decl))
1345                           common_var_decls)))
1346
1347     ;;(format t "*subprog_common_vars* = ~S~%" *subprog_common_vars*)
1348     ;;(format t "*common_array_dims* = ~S~%" *common_array_dims*)
1349     ;;(format t "declared = ~S~%" common_var_decls)
1350     
1351     (setf common-block-structs (make-common-block-structure common_var_decls))
1352     (when (member :insert-declaration *f2cl-trace*)
1353       (format t "struct = ~S~%" common-block-structs))
1354
1355     (setq common-blocks
1356           (if *declare-common-blocks*
1357               common-block-structs
1358               nil))
1359
1360     (when (member :insert-declaration *f2cl-trace*)
1361       (format t "*declare-common-blocks* = ~S~%" *declare-common-blocks*)
1362       (format t "spec-proc = ~S~%" common-blocks))
1363     
1364     ;;(format t "common-blocks = ~a~%" common-blocks)
1365
1366     ;; Get the declarations for all functions
1367     (multiple-value-setq (stmt-fcn-decls other-fcn-decls arg-fcn-decls)
1368       (make-fcn-decl *functions-used* arglist))
1369
1370     #+nil
1371     (setq formal-arg-decls
1372           (pretty-decls
1373            (append
1374             ;; Declare any function arguments
1375             (if (equalp arg-fcn-decls '((declare)))
1376                 nil
1377                 arg-fcn-decls)
1378             ;; Declare variables
1379             (mapcar #'(lambda (vble)
1380                         (let ((decl
1381                                (make-declaration vble :vble-is-formal-arg t)))
1382                           (format t "~S: ~S is ~S~%" defun-bit vble decl)
1383                           (setf *declared_vbles*
1384                                 (remove vble *declared_vbles*))
1385                           (setf *undeclared_vbles*
1386                                 (remove vble *undeclared_vbles*))
1387                           decl))
1388                     (set-difference arglist *external-function-names*)))))
1389     ;;(format t "*functions used* = ~S~%" *functions-used*)
1390     (let* ((var-decls nil)
1391            (var-type-list
1392              (mapcar #'(lambda (vble)
1393                          (if (or (member vble *external-function-names*)
1394                                  (member vble *functions-used*
1395                                          :key #'caar))
1396                              t
1397                              (let ((decl
1398                                     (make-declaration vble :vble-is-formal-arg t)))
1399                                (destructuring-bind (declare-sym (type-sym type var))
1400                                    decl
1401                                  (declare (ignore declare-sym type-sym var))
1402                                  (push decl var-decls)
1403                                  (setf *declared_vbles*
1404                                        (remove vble *declared_vbles*))
1405                                  (setf *undeclared_vbles*
1406                                        (remove vble *undeclared_vbles*))
1407                                  type))))
1408                      arglist)
1409              ))
1410       (setf var-decls (nreverse var-decls))
1411
1412       ;; (format t "declare ~S: ~S~%" (second defun-bit) var-type-list)
1413       (let ((entry (gethash (second defun-bit) *f2cl-function-info*)))
1414         (if entry
1415             (setf (f2cl-finfo-arg-types entry) (relax-array-decl var-type-list))
1416             (setf (gethash (second defun-bit) *f2cl-function-info*)
1417                   (make-f2cl-finfo :arg-types var-type-list))))
1418       (setq formal-arg-decls
1419           (pretty-decls
1420            (append
1421             ;; Declare any function arguments
1422             (if (equalp arg-fcn-decls '((declare)))
1423                 nil
1424                 arg-fcn-decls)
1425             ;; Declare variables
1426             var-decls))))
1427       
1428
1429     ;;(format t "formal-arg-decls = ~A~%" formal-arg-decls)
1430     (when *relaxed-array-decls*
1431       ;; Old Fortran practice often declared arrays to functions to
1432       ;; have length 1.  Since Fortran didn't check array bounds,
1433       ;; this basically meant such arrays could have any length.
1434       ;; This bit of code converts any such explicit declarations of
1435       ;; sizes to '*, meaning anything goes.
1436       (setf formal-arg-decls
1437             (list
1438              (mapcar #'(lambda (decl)
1439                          (cond ((and (listp decl)
1440                                      (eq 'type (first decl))
1441                                      (subtypep (second decl) 'array))
1442                                 (destructuring-bind (a &optional n l)
1443                                     (second decl)
1444                                   (if (subtypep a 'string)
1445                                       `(type (,a *)
1446                                              ,@(rest (rest decl)))
1447                                       `(type (,a ,n ,(mapcar #'(lambda (x)
1448                                                                  (declare (ignore x))
1449                                                                  '*)
1450                                                              l))
1451                                              ,@(rest (rest decl))))))
1452                                (t
1453                                 decl)))
1454                      (first formal-arg-decls)))))
1455
1456     ;;(format t "maybe relaxed formal-arg-decls = ~A~%" formal-arg-decls)
1457
1458     ;; Clean up other-fcn-decls.  If there weren't any, make it so,
1459     ;; instead of leaving it as an empty declare.
1460     (if (equal other-fcn-decls '((declare)))
1461         (setf other-fcn-decls nil)
1462         (setf other-fcn-decls (pretty-decls other-fcn-decls)))
1463
1464     (setf other-fcn-decls nil)
1465     
1466     ;; If we are auto-SAVE'ing variables initialized in DATA
1467     ;; statements, we add all of the variables in the *data-init* list
1468     ;; to the *save_vbles* list, removing duplicates.
1469
1470     (flet ((extract-var-name (setter)
1471              ;; From the setting form, we extract the variable name.
1472              ;; Currently setters look something like this:
1473              ;;
1474              ;; (setq var val)
1475              ;;
1476              ;; (replace array '(a b c ...))
1477              ;;
1478              ;; (fset (fref array n bounds) v)
1479              ;;
1480              ;; (data-implied-do do-loop var val)
1481
1482              ;;(format t "e-v-n:  ~S~%" setter)
1483              (when (listp setter)
1484                (cond ((eq 'setq (first setter))
1485                       (second setter))
1486                      ((eq 'replace (first setter))
1487                       (second setter))
1488                      ((eq 'fset (first setter))
1489                       (second (second setter)))
1490                      ((eq 'data-implied-do (first setter))
1491                       (find-data-var (second setter)))))))
1492       (when (and *auto-save-data* *data-init* (not (eq *save_vbles* '%save-all-locals%)))
1493         (setf *save_vbles*
1494               (remove-duplicates
1495                (append *save_vbles*
1496                        (remove nil
1497                                (flatten-list
1498                                 (mapcar #'extract-var-name
1499                                         *data-init*))))))))
1500
1501     ;; If a variable names a function used or an external function,
1502     ;; delete the variable.
1503     (setf *declared_vbles*
1504           (remove-if #'(lambda (v)
1505                          (or (member v *functions-used* :key #'caar)
1506                              (member v *external-function-names*)))
1507                      *declared_vbles*))
1508     ;; If a variable names a function used or an external function or
1509     ;; delete the variable.
1510     (setf *undeclared_vbles*
1511           (remove-if #'(lambda (v)
1512                          (or (member v *functions-used* :key #'caar)
1513                              (member v *external-function-names*)))
1514                      *undeclared_vbles*))
1515
1516     ;;(format t "*key_params* = ~S~%" *key_params*)
1517     ;;(format t "key-params = ~S~%" key-params)
1518
1519     ;; Convert reserved names in parameter statements.  Coerce the
1520     ;; bindings to the right type as well.
1521     (setq key-params
1522           (mapcar #'(lambda (x)
1523                       (let ((maybe-new-name (check-reserved-lisp-names (car x))))
1524                                   
1525                         (list maybe-new-name
1526                               (coerce-parameter-assign maybe-new-name (cadr x)))))
1527                   *key_params*))
1528     ;;(format t "key-params = ~S~%" key-params)
1529     
1530     (when (eq *save_vbles* '%save-all-locals%)
1531       ;; If *save_vbles* is the magic '%save-all-locals%, we want to
1532       ;; save all local variables.
1533       (setf *save_vbles* (concatenate 'list *declared_vbles* *undeclared_vbles*)))
1534
1535     ;; No need to save key-params
1536     (setf *save_vbles* (set-difference *save_vbles* (mapcar #'first *key_params*)))
1537
1538     ;; Initialize local variables
1539     (setq local-vbles
1540           (remove-duplicates
1541            (remove nil
1542                    (mapcar #'make-initialisation
1543                            (remove-if
1544                             #'(lambda (x)
1545                                 (or (member x *save_vbles*)
1546                                     (member x key-params :key #'car)))
1547                             (set-difference (append *declared_vbles*
1548                                                     *undeclared_vbles*)
1549                                             *subprog_common_vars*))))
1550            :test #'(lambda (a b)
1551                      (eq (first a) (first b)))))
1552
1553     ;; Remove %false% and %true% from the initialization lists.
1554     (setf local-vbles (remove-if #'(lambda (x)
1555                                      (member (first x) '(%false% %true%)))
1556                                  local-vbles))
1557
1558     ;; Declare local variables, but remove any variables explicitly
1559     ;; declared as SAVE'd.
1560     (setq vble-decls
1561           (pretty-decls
1562            (remove-if
1563             #'(lambda (x)
1564                 (member (third (second x)) '(%false% %true%)))
1565             (remove-duplicates
1566              (remove nil
1567                      (mapcar #'(lambda (vble)
1568                                  (make-declaration vble
1569                                                    :vble-is-formal-arg nil))
1570                              (remove-if
1571                               #'(lambda (x)
1572                                   (or (member x *save_vbles*)))
1573                               (set-difference
1574                                (append
1575                                 (set-difference *declared_vbles*
1576                                                 (mapcar #'car key-params))
1577                                 *undeclared_vbles*)
1578                                *subprog_common_vars*))))
1579              :test #'(lambda (a b)
1580                        (eq (third (second a))
1581                            (third (second b))))))))
1582
1583     ;; If we have saved variables, setup their declarations too.
1584     ;;(format t "*save_vbles* = ~S~%" *save_vbles*)
1585     (setq saved-decls
1586           (pretty-decls
1587            (remove-if
1588             #'(lambda (x)
1589                 (member (third (second x)) '(%false% %true%)))
1590             (remove-duplicates
1591              (remove nil
1592                      (mapcar #'(lambda (vble)
1593                                  (make-declaration vble
1594                                                    :vble-is-formal-arg nil))
1595                              *save_vbles*))
1596              :test #'(lambda (a b)
1597                        (eq (third (second a))
1598                            (third (second b))))))))
1599     ;;(format t "saved-decls = ~S~%" saved-decls)
1600
1601     ;; Initialize SAVE'd variables appropriately.  But don't need to
1602     ;; initialize SAVE'd variables that are in common blocks.
1603     (setq save-inits
1604           (remove-duplicates
1605            (remove nil
1606                    (mapcar #'make-initialisation
1607                            (remove-if
1608                             #'(lambda (x)
1609                                 (member x key-params :key #'car))
1610                             *save_vbles*)))
1611            :test #'(lambda (a b)
1612                      (eq (first a) (first b)))))
1613
1614     ;; Clean up data inits: handle the fset inits and the
1615     ;; data-implied-do inits.
1616     #+nil
1617     (progn
1618       (format t "save-inits*: ~S~%" save-inits)
1619       (format t "*data-init* before: ~S~%" *data-init*))
1620     (setq *data-init*
1621           (mapcar #'(lambda (init)
1622                       (flet ((get-dims (var)
1623                                (mapcar #'(lambda (v)
1624                                            (lookup-array-bounds
1625                                             (check-reserved-lisp-names
1626                                              (find-data-var v))))
1627                                        (if (listp var) var (list var))))
1628                              (get-types (vars)
1629                                ;; I'm lazy.  Use make-declaration
1630                                ;; to figure out the type of the array
1631                                ;; element.
1632                                #+nil
1633                                (mapcar #'(lambda (v)
1634                                            (let ((init (make-declaration
1635                                                         (find-data-var (check-reserved-lisp-names v)))))
1636                                              (second (second (second init)))))
1637                                        vars)
1638                                ;; Look through explicit_vble_decls
1639                                (mapcar #'(lambda (v)
1640                                            (let ((v (find-data-var (check-reserved-lisp-names v))))
1641                                              (dolist (d *explicit_vble_decls*)
1642                                                (destructuring-bind (vtype &rest vars)
1643                                                    d
1644                                                  (when (member v vars :key #'car)
1645                                                    (return (list vtype)))))))
1646                                        vars)
1647                                ))
1648
1649                       (cond #+nil
1650                             ((eq 'fset (first init))
1651                              ;; We need to get the dimensions for this array
1652                              (destructuring-bind (fset (fref var idx) val)
1653                                  init
1654                                (declare (ignore fset fref))
1655                                `(fset (fref ,var ,idx ,(get-dims var)) ,val)))
1656                             ((eq 'data-implied-do (first init))
1657                              ;; We need to get the dimensions for
1658                              ;; this array as well as the types.
1659                              (destructuring-bind (ido loop var vals)
1660                                  init
1661                                (declare (ignore ido))
1662                                `(data-implied-do ,loop
1663                                                  ,@(mapcar #'get-dims var)
1664                                                  ,@(mapcar #'get-types var)
1665                                                  ,vals)))
1666                             ((and (eq 'replace (first init))
1667                                   (not (search "/blockdata" (string (second defun-bit))
1668                                                :test #'equalp)))
1669                              ;; These are initialized by
1670                              ;; f2cl-init-string (I hope).  But for
1671                              ;; block data subprograms, we want to
1672                              ;; initialize it, to be sure.  (See
1673                              ;; donlp2, boxparam test, for example.)
1674                              nil)
1675                             (t
1676                              init))))
1677                   *data-init*))
1678     ;;(format t "*data-init* after : ~S~%" *data-init*)
1679     (setf *data-init* (delete nil *data-init*))
1680     ;;(format t "*data-init* after : ~S~%" *data-init*)
1681     
1682     (setq arglist (mapcar #'check-reserved-lisp-names arglist))
1683
1684     ;;(format t "arglist = ~a~%" arglist)
1685     #+nil
1686     
1687     (format t "arglist arrays = ~A~%"
1688             (remove nil
1689                     (mapcar #'(lambda (x)
1690                                 (if (subtypep (second x) 'array)
1691                                     (cddr x)
1692                                     nil))
1693                             (rest (first formal-arg-decls)))))
1694     ;;(format t "local-vbles     = ~S~%" local-vbles)
1695     ;;(format t "vbles-decls     = ~S~%" vble-decls)
1696     ;;(format t "other-fcn-decls = ~S~%" other-fcn-decls)
1697     ;;(format t "body            = ~S~%" body)
1698     (setf all-decls (append (rest (first vble-decls))
1699                             (rest (first other-fcn-decls))))
1700     (setf all-decls `((declare ,@all-decls)))
1701     ;;(format t "all-decls = ~A~%" all-decls)
1702
1703     (when *entry-points*
1704       ;; First make sure the entry points are consistent in name and
1705       ;; number of arguments.  We don't support anything else (yet?)
1706       (unless (every #'(lambda (f)
1707                          (let ((result (equal (second f) arglist)))
1708                            (unless result
1709                              (warn "ENTRY ~A doesn't match the expected arg list: ~A~%" (second f) arglist))
1710                            result))
1711                      *entry-points*)
1712         (warn "Some ENTRY points don't match the expected signature ~A~%"
1713               arglist))
1714
1715       ;; Add entry points to the function database
1716
1717       (dolist (f *entry-points*)
1718         ;;(format t "Adding entry point ~A to database~%" f)
1719         (destructuring-bind (name args &optional parent)
1720             f
1721           ;;(format t "name, args, parent = ~A ~A ~A~%" name args parent)
1722           (let ((entry (gethash name *f2cl-function-info*))
1723                 (var-type-list (get-var-types args)))
1724             #+nil
1725             (progn
1726               (format t "entry = ~A~%" entry)
1727               (format t "var-type-list = ~A~%" var-type-list)
1728               (format t "parent info = ~A~%" (gethash parent *f2cl-function-info*)))
1729             (cond
1730               (parent
1731                ;; If we know parent of the entry point function, we
1732                ;; copy the information from the parent to this entry.
1733                ;; (Because we only support entry points with the same
1734                ;; number and type of args.)
1735                (let ((pe (gethash parent *f2cl-function-info*)))
1736                  (cond
1737                    (entry
1738                     (setf (f2cl-finfo-arg-types entry)
1739                           (f2cl-finfo-arg-types pe))
1740                     (setf (f2cl-finfo-return-values entry)
1741                           (f2cl-finfo-return-values pe)))
1742                    (t
1743                     (setf (gethash name *f2cl-function-info*)
1744                           (make-f2cl-finfo :arg-types (f2cl-finfo-arg-types pe)
1745                                            :return-values (f2cl-finfo-return-values pe)))))))
1746               (t
1747                (warn "Got entry point for which we have no parent!")
1748                (if entry
1749                    (setf (f2cl-finfo-arg-types entry) var-type-list)
1750                    (setf (gethash name *f2cl-function-info*)
1751                          (make-f2cl-finfo :arg-types var-type-list))))))))
1752       
1753       (setf entry-points
1754             (mapcar #'(lambda (x)
1755                         (let ((name (first x)))
1756                           `(if (eq %name% ',name) (go ,name))))
1757                     *entry-points*)))
1758     
1759     ;;(format t "entry-points = ~A~%" entry-points)
1760       
1761     (setq prog-bit
1762           (if (or *save_vbles* *auto-save-data*)
1763               ;; If we have SAVE'd variables, don't put their inits
1764               ;; into the function.  Put them in the let outside the function
1765               ;; where they belong.
1766               (if *subprog-stmt-fns*
1767                   `(labels ,*subprog_stmt_fns_bodies* ,@stmt-fcn-decls
1768                     (prog ,local-vbles ,@all-decls ,@entry-points ,@body))
1769                   `(prog ,local-vbles ,@all-decls ,@entry-points ,@body))
1770               (if *subprog-stmt-fns*
1771                   `(labels ,*subprog_stmt_fns_bodies* ,@stmt-fcn-decls
1772                     (prog ,local-vbles ,@all-decls ,@*data-init* ,@entry-points ,@body))
1773                   `(prog ,local-vbles ,@all-decls ,@*data-init* ,@entry-points ,@body)))
1774               )
1775     ;;(format t "prog-bit = ~%~S~%" prog-bit)
1776
1777     ;; Do some common fixups to make the code faster (for compilers
1778     ;; not sufficiently smart) and prettier
1779
1780     (setf prog-bit (fixup-expression (fixup-expr-mul prog-bit)))
1781
1782     (setf prog-bit (fixup-relop prog-bit))
1783
1784     (setf prog-bit (merge-ops prog-bit))
1785
1786     ;; Try to optimize out calls to f2cl/.
1787     ;;(format t "fixed-up prog-bit = ~%~S~%" prog-bit)
1788     (setf prog-bit (optimize-f2cl/ prog-bit))
1789
1790     ;;(format t "before opt int:~%~A~%" prog-bit)
1791     (setf prog-bit (optimize-integer-arithmetic prog-bit))
1792     ;;(format t "after opt int:~%~A~%" prog-bit)
1793     ;;(format t "opt prog = ~%~S~%" prog-bit)
1794     ;;(format t "*save_vbles* = ~a~%" *save_vbles*)
1795     ;;(format t "*data-init* = ~S~%" *data-init*)
1796     ;;(format t "save-inits  = ~S~%" save-inits)
1797
1798     (when *enable-merging-data-and-save-init*
1799       ;; Common variables are always SAVE'd in f2cl, so remove those
1800       ;; from the save-inits list.
1801       
1802       ;;(format t "*subprog_common_vars* = ~A~%" *subprog_common_vars*)
1803       (let ((non-common-save-inits
1804              (remove-if #'(lambda (item)
1805                             (member (first item) *subprog_common_vars*))
1806                         save-inits)))
1807         ;;(format t "non-common-save-inits  = ~S~%" non-common-save-inits)
1808         (multiple-value-setq (save-inits *data-init*)
1809           (merge-data-and-save-inits non-common-save-inits *data-init*)))
1810       ;; Clean up saved-decls
1811       (let ((all-inits (append save-inits *data-init*))
1812             (new-decls))
1813         #+(or)
1814         (progn
1815           (format t "all-inits = ~S~%" all-inits)
1816           (format t "saved-decls = ~S~%" (car saved-decls))
1817           (format t "cddr saved-decls = ~S~%" (cdar saved-decls)))
1818         (dolist (d (cdar saved-decls))
1819           (let ((vars (remove-if-not #'(lambda (v)
1820                                          (member (car v) (cddr d)))
1821                                      all-inits)))
1822             (when vars
1823               (push `(,(car d) ,(second d)
1824                        ,@(mapcar #'car vars))
1825                     new-decls))))
1826         (when new-decls
1827           (setf saved-decls `((declare ,@new-decls))))
1828         ;;(format t "new-saved-decls = ~S~%" saved-decls)
1829         ))
1830     
1831     ;;(format t "new *data-init* = ~S~%" *data-init*)
1832     ;;(format t "new save-inits  = ~S~%" save-inits)
1833     
1834     ;;(format t "prog-bit = ~a~%" prog-bit)
1835     
1836     ;; Clean up key params by removing any unused key params. This
1837     ;; means not used in the code or for intializing data statements.
1838     (setf code-key-params (remove-unused-key-params key-params
1839                                                     (list *data-init*
1840                                                           save-inits
1841                                                           prog-bit)))
1842
1843     (setf code-key-params-decls (make-key-param-decls code-key-params))
1844     
1845
1846     ;; Replace all references to external functions with #'.
1847     ;; However, if the external function was on the parameter list,
1848     ;; we don't need to do that.
1849     (setf prog-bit (fixup-external-function-refs
1850                     prog-bit
1851                     (set-difference *external-function-names* arglist)))
1852     ;; Do the same for intrinsic function names, but be sure to
1853     ;; remove any variables whose name might match an intrinsic
1854     ;; function name.
1855
1856     (when (member :insert-declaration *f2cl-trace*)
1857       (format t "key-params            = ~A~%" key-params)
1858       (format t "*declared_vbles*      = ~A~%" *declared_vbles*)
1859       (format t "*undeclared_vbles*    = ~A~%" *undeclared_vbles*)
1860       (format t "*subprog_common_vars* = ~A~%" *subprog_common_vars*)
1861       (format t "arglist               = ~A~%" arglist))
1862     (setf prog-bit
1863           (fixup-external-function-refs
1864            prog-bit
1865            (set-difference *intrinsic-function-names*
1866                            (append *declared_vbles*
1867                                    *undeclared_vbles*
1868                                    arglist
1869                                    (mapcar #'first key-params)))))
1870
1871     ;; Add additional parameters for slicing
1872     #+nil
1873     (let ((array-args
1874            (let ((a '()))
1875              (mapc #'(lambda (x)
1876                        (when (subtypep (second x) 'array)
1877                          (mapc #'(lambda (y)
1878                                    (push y a))
1879                                (cddr x))))
1880                    (rest (first formal-arg-decls)))
1881              (nreverse a))))
1882       ;;(format t "array-args = ~A~%" array-args)
1883       (setf additional-args
1884             (remove nil
1885                     (mapcar #'(lambda (x)
1886                                 (when (member x array-args)
1887                                   (list (intern (concatenate 'string
1888                                                              (symbol-name x)
1889                                                              (symbol-name '#:-offset)))
1890                                         0)))
1891                             arglist)))
1892       ;;(format t "additional args = ~A~%" additional-args)
1893
1894       ;;(format t "arglist = ~a~%" arglist)
1895       (when additional-args
1896         (setf arglist (append arglist `(&optional ,@additional-args))))
1897       ;;(format t "new arglist = ~a~%" arglist)
1898
1899       ;; Grovel over the code looking for frefs.  Modify them to handle
1900       ;; array-slicing.
1901
1902       ;;(format t "prog-bit = ~A~%" prog-bit)
1903
1904       (labels
1905           ((array-offset-name (name)
1906              (intern (concatenate 'string
1907                                   (symbol-name name)
1908                                   (symbol-name '#:-offset))))
1909            (grovel-call (p)
1910              ;;(format t "grovel-call = ~A~%" p)
1911              (let* ((offsets '())
1912                     (new-call
1913                      (mapcar
1914                       #'(lambda (x)
1915                           ;;(format t "x = ~A~%" x)
1916                           (cond
1917                             ((and (listp x)
1918                                   (eq (first x) 'array-slice))
1919                              ;; (array-slice var type (indices) bounds)
1920                              (push `(+ ,(if (member (second x) array-args)
1921                                             (array-offset-name (second x))
1922                                             0)
1923                                      ,(f2cl-lib::col-major-index (fourth x)
1924                                                                  (fifth x)))
1925                                    offsets)
1926                              (second x))
1927                             ((member x array-args)
1928                              (push (array-offset-name x)
1929                                    offsets)
1930                              x)
1931                             ((vble-is-array-p x)
1932                              (push 0 offsets)
1933                              x)
1934                             (t
1935                              x)))
1936                       p)))
1937                (append new-call (reverse offsets))))
1938            (grovel-frefs (p)
1939              (cond ((or (atom p) (null p))
1940                     p)
1941                    ((eq (first p) 'fref)
1942                     (destructuring-bind (fref-name var &rest stuff)
1943                         p
1944                       (if (member var array-args)
1945                           ;; We have an fref.  If the array is an argument
1946                           ;; to the routine, we need to add in the offset.
1947                           `(,fref-name ,var ,@stuff ,(array-offset-name var))
1948                           p)))
1949                    ((eq (first p) 'multiple-value-bind)
1950                     ;; A Fortran function call.
1951                     (destructuring-bind (m-v-b vars call &rest stuff)
1952                         p
1953                       `(,m-v-b ,vars ,(grovel-call call) ,@stuff)))
1954                    ((and (symbolp (first p))
1955                          (member 'array-slice (rest p)
1956                                  :key #'(lambda (x)
1957                                           (if (listp x)
1958                                               (car x)
1959                                               x))))
1960                     ;; array-slice in a function call.
1961                     ;;(format t "array-slice in fcall: ~a~%" p)
1962                     `(,(first p) ,@(grovel-call (rest p))))
1963                    ((and (symbolp (first p))
1964                          (some #'(lambda (x)
1965                                    (member x array-args))
1966                                (rest p)))
1967                     `(,(first p) ,@(grovel-call (rest p))))
1968                    (t
1969                     `(,(first p) ,@(mapcar #'grovel-frefs (rest p)))))))
1970         (setf prog-bit (grovel-frefs prog-bit))
1971         ;;(format t "new-prog-bit = ~A~%" prog-bit)
1972         ))
1973
1974     (let ((array-args
1975            (let ((a '()))
1976              (mapc #'(lambda (x)
1977                        (when (subtypep (second x) 'array)
1978                          (mapc #'(lambda (y)
1979                                    (push y a))
1980                                (cddr x))))
1981                    (rest (first formal-arg-decls)))
1982              (nreverse a))))
1983       ;;(format t "array-args = ~A~%" array-args)
1984       
1985       
1986       ;;(format t "arglist = ~a~%" arglist)
1987       ;;(format t "new arglist = ~a~%" arglist)
1988
1989       ;; Grovel over the code looking for frefs.  Modify them to handle
1990       ;; array-slicing.
1991
1992       ;;(format t "prog-bit = ~A~%" prog-bit)
1993
1994       (labels
1995           ((array-offset-name (name)
1996              (intern (concatenate 'string
1997                                   (symbol-name name)
1998                                   (symbol-name '#:-%offset%))))
1999            (array-data-name (name)
2000              (intern (concatenate 'string
2001                                   (symbol-name name)
2002                                   (symbol-name '#:-%data%))))
2003            (grovel-frefs (p)
2004              (cond ((or (atom p) (null p))
2005                     p)
2006                    ((eq (first p) 'fref)
2007                     (destructuring-bind (fref-name var &rest stuff)
2008                         p
2009                       (if (member var array-args)
2010                           ;; We have an fref.  If the array is an argument
2011                           ;; to the routine, we need to add in the offset.
2012                           `(,fref-name ,(array-data-name var)
2013                                        ,@stuff ,(array-offset-name var))
2014                           p)))
2015                    ((eq (first p) 'array-slice)
2016                     (destructuring-bind (array-slice-name var &rest stuff)
2017                         p
2018                       (if (member var array-args)
2019                           `(,array-slice-name ,(array-data-name var)
2020                                               ,@stuff
2021                                               ,(array-offset-name var))
2022                           p)))
2023                    (t
2024                     `(,(first p) ,@(mapcar #'grovel-frefs (rest p))))))
2025            (generate-with-array (arrays body)
2026              (let (array-data-forms)
2027                (flet ((find-type (a)
2028                         (dolist (x (rest (first formal-arg-decls)))
2029                           (when (member a (cddr x))
2030                             (return-from find-type (second (second x))))
2031                           t)))
2032                  (dolist (a arrays)
2033                    (let ((d-name (array-data-name a))
2034                          (o-name (array-offset-name a))
2035                          (d-type (find-type a)))
2036                      (push `(,a ,d-type ,d-name ,o-name) array-data-forms)))
2037                  (if array-data-forms
2038                      `(with-multi-array-data ,array-data-forms
2039                        ,body)
2040                      body)))))
2041         ;;(format t "formal-arg-decls = ~A~%" formal-arg-decls)
2042
2043         (when *equivalenced-vars*
2044           (multiple-value-bind (equiv simple-vars)
2045               (verify-and-generate-equivalences)
2046             ;;(setf equivalences equiv)
2047             ;;(format t "equivalences = ~A~%" equivalences)
2048
2049             ;; We need to go through prog-bit and remove any
2050             ;; initializations and declarations of the simple-vars
2051             ;; that were equivalenced.  Otherwise the initialization
2052             ;; will very likely mess up the equivalence.
2053
2054             ;;(format t "prog = ~A~%" (second prog-bit))
2055             (let ((fixed (remove-if #'(lambda (x)
2056                                         (member x simple-vars))
2057                                     (second prog-bit)
2058                                     :key #'first)))
2059               ;;(format t "inits = ~A~%" (second prog-bit))
2060               ;;(format t "fixed = ~A~%" fixed)
2061               (setf prog-bit `(prog ,fixed ,@(cddr prog-bit))))
2062             
2063             (setf prog-bit `(symbol-macrolet ,equiv
2064                               ,prog-bit))))
2065
2066         ;; If array-slicing is not used and the array-type is
2067         ;; :simple-array, we don't need the with-array-data stuff
2068         ;; because we couldn't have sliced the array.
2069         (when (eq *array-type* 'common-lisp:array)
2070           (setf prog-bit (grovel-frefs prog-bit))
2071           ;;(format t "new-prog-bit = ~A~%" prog-bit)
2072
2073           (setf prog-bit (generate-with-array array-args prog-bit)))
2074           ;;(format t "new-prog-bit = ~A~%" prog-bit)
2075                 
2076         ))
2077
2078     ;; We need to handle BLOCK DATA subprograms differently from
2079     ;; normal subprograms.  (BLOCK DATA subprograms always start with
2080     ;; "/BLOCKDATA".  See f2cl1.l that sets this name.)
2081     (cond
2082       ((and (let* ((sub-name (string (second defun-bit)))
2083                    (name-len (min 10 (length sub-name))))
2084               (string-equal sub-name "/blockdata" :end1 name-len :end2 name-len))
2085             *subprog_common_vars*)
2086        ;; Block data subprograms need to be handled specially.  The
2087        ;; data-init part needs to be moved inside the body and
2088        ;; massaged to initialize the data. 
2089        (multiple-value-bind (sym-macs sym-lets)
2090            (create-sym-macros (list save-inits *data-init*))
2091          #+nil
2092          (format t "save-inits = ~A~%" (mapcar #'(lambda (x)
2093                                                    `(setf ,@x))
2094                                                save-inits))
2095          #+nil
2096          (format t "data-inits = ~A~%"
2097                  (mapcar #'(lambda (x)
2098                              (if (eq (first x) 'setq)
2099                                  `(setf ,@(rest x))
2100                                  x))
2101                          *data-init*))
2102          ;; May want to remove multiple initializations since
2103          ;; save-inits and *data-init* might both initiliaze the
2104          ;; variable.  (Why is that?)
2105          (setf prog-bit
2106                `(let ,sym-lets
2107                  (symbol-macrolet ,sym-macs
2108                  ,@(append (mapcar #'(lambda (x)
2109                                        `(setf ,@x))
2110                                    save-inits)
2111                            (mapcar #'(lambda (x)
2112                                        (if (eq (first x) 'setq)
2113                                            `(setf ,@(rest x))
2114                                            x))
2115                                    *data-init*))))))
2116        (setf code-key-params (remove-unused-key-params key-params prog-bit))
2117        (setf code-key-params-decls (make-key-param-decls code-key-params))
2118        (let* ((defun-stuff `(defun ,(cadr defun-bit) ,arglist
2119                              ,prog-bit))
2120               (param-stuff (if code-key-params
2121                                `(let* ,code-key-params
2122                                  ,@code-key-params-decls
2123                                  ,defun-stuff)
2124                                defun-stuff)))
2125          (return
2126            (values common-blocks
2127                    (when common-blocks
2128                      (make-common-block-init *common-blocks* common_var_decls
2129                                              key-params))
2130                    param-stuff))
2131          )
2132        )
2133       (t
2134        ;; Return 3 pieces: Any proclamations for special variables, the
2135        ;; declarations for the special variables, and, finally, the
2136        ;; function itself.
2137        (when *subprog_common_vars*
2138          (multiple-value-bind (sym-macs sym-lets)
2139              (create-sym-macros prog-bit)
2140            (setf prog-bit `(let ,sym-lets
2141                              (symbol-macrolet ,sym-macs ,prog-bit)))))
2142
2143        ;; Handle entry points.
2144        (let* ((defun (if *entry-points* 'labels 'defun))
2145               (defun-name (if *entry-points*
2146                               (intern (concatenate 'string (symbol-name '#:multi-entry-)
2147                                                    (string (cadr defun-bit))))
2148                               (cadr defun-bit)))
2149               (defun-stuff (if *entry-points*
2150                                `(,defun ((,defun-name (%name% ,@arglist)
2151                                          ,@(unless (equal formal-arg-decls '((declare)))
2152                                            formal-arg-decls)
2153                                          ,prog-bit))
2154                                  ,@(entry-functions defun-name (cadr defun-bit) arglist))
2155                                `(,defun ,defun-name ,arglist
2156                                  ;; Remove empty declaration
2157                                  ,@(unless (equal formal-arg-decls '((declare)))
2158                                            formal-arg-decls)
2159                                  ,prog-bit)))
2160               (save-stuff (if (and (or *save_vbles* *auto-save-data*)
2161                                    save-inits)
2162                               `(let ,save-inits
2163                                 ,@saved-decls
2164                                 ,@*data-init*
2165                                 ,defun-stuff)
2166                               defun-stuff))
2167               (param-stuff (if code-key-params
2168                                `(let* ,code-key-params
2169                                  ,@code-key-params-decls
2170                                  ,save-stuff)
2171                                save-stuff)))
2172          ;;(format t "save-stuff = ~A~%" save-stuff)
2173          ;;(format t "param-stuff = ~A~%" param-stuff)
2174          (return
2175            (values common-blocks
2176                    (when common-blocks
2177                      (make-common-block-init *common-blocks* common_var_decls
2178                                              key-params))
2179                    param-stuff)))))
2180     ))
2181
2182
2183
2184;; given vble return (vble init-value)
2185;; for prog arglist
2186
2187(defun vble-declared-twice-p (vble vble_decls)
2188  (let ((ndecls 0)
2189        v-type v-name)
2190    (dolist (type-list vble_decls)
2191      (let ((found (member vble (rest type-list) :key #'car)))
2192        (when found
2193          (incf ndecls)
2194          (push (first type-list) v-type)
2195          (push (car found) v-name))))
2196    (when (> ndecls 1)
2197      (mapcar #'list v-type v-name))))
2198
2199
2200(defun make-initialisation (vble)
2201  ;; Look up variable in *data-init* to see if it has an
2202  ;; initialized value from a data statement
2203  (flet ((lookup-data-init (v)
2204           (let ((val (find-if #'(lambda (name)
2205                                   (eq v (second name)))
2206                               *data-init*)))
2207             ;;(format t "lookup-data-init for ~S = ~S~%" v val)
2208             (when val
2209               (cond ((eq 'fill (first val))
2210                      (list 'fill (third val)))
2211                     ((eq 'setq (first val))
2212                      (third val))
2213                     ((eq 'replace (first val))
2214                      (third val)))))))
2215    (let* ((vble_name (check-reserved-lisp-names vble))
2216           (init-val (lookup-data-init vble))
2217           type decl1)
2218      #+nil
2219      (progn
2220        (format t "*data-init* = ~A~%" *data-init*)
2221        (format t "*explicit_vble_decls* = ~a~%" *explicit_vble_decls*)
2222        (format t "*declared_vbles* = ~S~%" *declared_vbles*)
2223        (format t "*common_array_dims* = ~S~%" *common_array_dims*)
2224        (format t "vble = ~a~%" vble)
2225        (format t "init-val = ~S~%" init-val))
2226      (cond
2227        ;;check for vble with two declarations i.e. an array
2228        ((setf decl1 (vble-declared-twice-p vble *explicit_vble_decls*))
2229         #+nil
2230         (progn
2231           (format t "declared twice~%")
2232           (format t "vble-decl-done = ~S~%" *vble-declaration-done*))
2233         ;; If we've already processed this variable, we don't need to
2234         ;; do it again.
2235         (unless (member vble *vble-declaration-done*)
2236           (destructuring-bind (decl1 decl2)
2237               decl1
2238             ;; Remember that we have done this already
2239             (pushnew vble *vble-declaration-done*)
2240             (if (eq (car decl1) 'array)
2241                 `(,vble_name ,(make_make-array_stmt (cdadr decl1)
2242                                                     (car decl2)
2243                                                     init-val vble_name))
2244                 `(,vble_name ,(make_make-array_stmt (cdadr decl2)
2245                                                     (car decl1)
2246                                                     init-val vble_name))))))
2247           
2248        ;; Don't need any initialization for statement functions or
2249        ;; external functions.  (But perhaps we should put one in to
2250        ;; say these are actually functions?)
2251        ((or (member vble *external-function-names*)
2252             (member vble *subprog-stmt-fns*))
2253         nil
2254         )
2255        ;; check for declared variable
2256        ((member vble *declared_vbles*)
2257         #+nil
2258         (progn
2259           (format t "make-init: declared var:  ~A = ~A~%" vble init-val)
2260           (format t "explicit_vble_decls = ~A~%" *explicit_vble_decls*))
2261         (do ((type-clauses *explicit_vble_decls* (cdr type-clauses))
2262              (decl nil))
2263             ((null type-clauses) )
2264           (setq type (caar type-clauses))
2265           #+nil
2266           (progn
2267             (format t "type-clauses = ~S~%" type-clauses)
2268             (format t "looping: type = ~A~%" type))
2269           (cond ((and (listp type)
2270                       (eq (car type) 'character))
2271                  ;;(format t "member = ~S~%" (member vble (cdar type-clauses) :key #'car))
2272                  (if (setq decl (member vble (cdar type-clauses) :key #'car))
2273                      (return `(,vble_name ,
2274                                (make-char-init (car decl) type init-val)))))
2275                 ((eq type 'array)
2276                  #+nil
2277                  (progn
2278                    (format t "array type-clauses = ~S~%" (cdar type-clauses))
2279                    (format t "array decl = ~S~%" (member vble (cdar type-clauses) :key #'car)))
2280                  (if (setq decl (member vble (cdar type-clauses) :key #'car))
2281                      (return
2282                        `(,vble_name
2283                          ,(make_make-array_stmt
2284                            (cdar decl)
2285                            (get_array_type (caar decl) nil)
2286                            init-val
2287                            vble_name)))))
2288                 ((eq type 'logical)
2289                  (if (setq decl (member vble (cdar type-clauses) :key #'car))
2290                      (return
2291                        (if (cdar decl)
2292                            (flet ((fixup-logical (init)
2293                                     ;; Replace %false% with NIL and
2294                                     ;; %true% with T so we can
2295                                     ;; initialize the logical array
2296                                     ;; correctly.
2297                                     (subst t '%true% (subst nil '%false% init))))
2298                              (let ((init (make_make-array_stmt (cdar decl) t
2299                                                                (fixup-logical init-val)
2300                                                                vble_name)))
2301                                `(,vble_name ,init)))
2302                            `(,vble_name nil)))))
2303                 (t
2304                  #+nil
2305                  (progn
2306                    (format t "default decl = ~S~%" (member vble (cdar type-clauses) :key #'car))
2307                    (format t "default init-val = ~S~%" init-val))
2308                  #+nil
2309                  (progn
2310                    (format t "vble = ~S~%" vble)
2311                    (format t "vble_name = ~S~%" vble_name)
2312                    (format t "dims = ~S~%" *common_array_dims*)
2313                    (format t "subprog = ~S~%" *subprog_common_vars*))
2314
2315                  ;; If vble was dimensioned in a common block, we
2316                  ;; don't need to initialize it here.  I think.
2317                  (when (member vble *common_array_dims*)
2318                    (return nil))
2319
2320                  ;; If this variable is in a common block, we don't
2321                  ;; need to initialize it either.  It would have been
2322                  ;; initialized in the clauses above.  I think.
2323                  (when (and (setq decl (member vble (cdar type-clauses) :key #'car))
2324                             (not (member vble *subprog_common_vars*)))
2325                    (return
2326                      (if (cdar decl)
2327                          `(,vble_name
2328                            ,(make_make-array_stmt (cdar decl) type init-val vble_name))
2329                          `(,vble_name
2330                            ,(cond (init-val
2331                                    (remove-*data-init*-var vble_name)
2332                                    init-val)
2333                                   (t
2334                                    (ecase type
2335                                      ((fixnum integer4 integer2 integer1)
2336                                       0)
2337                                      (single-float 0f0)
2338                                      (double-float 0d0)
2339                                      ((complex complex8) #c(0f0 0f0))
2340                                      (complex16 #c(0d0 0d0)))))))))))))
2341        (t
2342         ;;(format t "implicit type = ~A~%" (get-implicit-type vble))
2343         (cond ((setq type (get-implicit-type vble))
2344                `(,vble_name ,(cond (init-val
2345                                     (remove-*data-init*-var vble_name)
2346                                     init-val)
2347                                    ((eq type 'fixnum) 0)
2348                                    ((eq type 'single-float) 0f0)
2349                                    ((eq type 'double-float) 0d0)
2350                                    ((eq type 'complex) '(complex 0f0 0f0))
2351                                    ((and (listp type)
2352                                          (eq (car type) 'character))
2353                                     (make-char-init (list vble) type))
2354                                    (t nil))))
2355               (t
2356                (when init-val
2357                  (remove-*data-init*-var vble_name))
2358                (if (default-int-p vble)
2359                    `(,vble_name ,(or init-val 0))
2360                    `(,vble_name ,(or init-val (if *promote-to-double* 0d0 0f0)))))))))))
2361
2362
2363(defun remove-*data-init*-var (vble)
2364  (setf *data-init* (remove-if #'(lambda (x)
2365                                 (equal vble (second x)))
2366                             *data-init*)))
2367
2368;; DIMS is a list of the dimensions of an array.  DATA is a list of
2369;; data to use for initializing an array.
2370(defun fortran-data-init (type dims data)
2371  (cond ((every #'numberp dims)
2372         ;; We can compute everything we need at compile time so let's
2373         ;; do it.
2374         (let ((data-len (length data))
2375               (total-length (reduce #'* dims)))
2376           (cond ((< data-len total-length)
2377                  ;; Need to append some data.
2378                  `(',(append data (make-list (- total-length data-len)
2379                                              :initial-element (coerce 0 type)))))
2380                 ((> data-len total-length)
2381                  ;; Need to truncate some data
2382                  `(',(subseq data 0 total-length)))
2383                 (t
2384                  `(',data)))))
2385        (t
2386         ;; Dispatch the creation to a macro to be compiled later by
2387         ;; Lisp.
2388         `((array-initialize ,type ,dims ,data))
2389         )))
2390
2391(defun make_make-array_stmt (dimens type &optional init vble)
2392  (let ((dims (mapcar #'(lambda (x)
2393                           (cond ((member '* x) '*)
2394                                 ((eq (car x) 1) (cadr x))
2395                                 ((not (member nil (mapcar #'numberp x)))
2396                                  (1+ (- (cadr x) (car x))))
2397                                 (t `(1+ (- ,(cadr x) ,(car x))))))
2398                       dimens)))
2399    ;; Don't need to initialize this variable separately, so kill it.
2400    (setf *data-init* (remove-*data-init*-var vble))
2401   
2402    (let ((init-val
2403           (when init
2404             (if (eq 'fill (first init))
2405                 `(:initial-element ,(second init))
2406                 `(:initial-contents
2407                   ,@(fortran-data-init type dims
2408                                        (first (rest init))))))))
2409      (cond ((every #'numberp dims)
2410             ;; If all of the dimensions are numbers, we don't have to
2411             ;; make a list out of them.  This can speed up array
2412             ;; creation for smart compilers.
2413             (if (= (length dims) 1)
2414                 `(make-array ,(first dims) :element-type ',type ,@init-val)
2415                 `(make-array ,(reduce #'* dims) :element-type ',type ,@init-val)))
2416            (t
2417             (if (= (length dims) 1)
2418                 `(make-array ,@dims :element-type ',type ,@init-val)
2419                 `(make-array (the fixnum (reduce #'* (list ,@dims))) :element-type ',type ,@init-val)))))))
2420
2421;; create a labels form for when statement functions are present
2422
2423(defun make-labels-form (local-vbles vble-decls *data-init* body)
2424    `(labels ,*subprog_stmt_fns_bodies*
2425      (prog ,local-vbles ,@vble-decls ,@*data-init* ,@body)))
2426
2427
2428;; Take the bounds of an array and compute the total size of the array
2429;; if possible.  If not, return '*.  Useful for getting the
2430;; appropriate type declaration for an array.
2431(defun f2cl-array-total-size (bounds)
2432  (list (reduce #'(lambda (accum y)
2433                    (if (and (numberp accum) (numberp y))
2434                        (* accum y)
2435                        '*)
2436                    )
2437                (mapcar #'(lambda (x)
2438                            (if (every #'realp x)
2439                                (1+ (reduce #'- (reverse x)))
2440                                '*))
2441                        bounds))))
2442
2443;; make a declaration for vble which may or may not be a formal arg
2444;; vble_name is used to replace vbles called T with T_
2445;;
2446;; If vble is defined in a PARAMETER statement, :PARAMETERP should be
2447;; set to the value of the parameter.  This will generate appropriate
2448;; declarations for the parameter.
2449(defun make-declaration (vble &key vble-is-formal-arg parameterp)
2450 (prog (vble_name type decl1)
2451   (setq vble_name (check-reserved-lisp-names vble))
2452  (return
2453   (cond
2454     ;;check for vble with two declarations i.e. an array
2455     ((setf decl1 (vble-declared-twice-p vble *explicit_vble_decls*))
2456      (destructuring-bind (decl1 decl2)
2457          decl1
2458        (when (eq (car decl2) 'array)
2459          (rotatef decl1 decl2))
2460        (return `(declare (type (,(if (and vble-is-formal-arg *array-slicing*)
2461                                      'array
2462                                      *array-type*)
2463                                 ,(car decl2)
2464                                 ,(f2cl-array-total-size (cdadr decl1))
2465                                 )
2466                                 ,vble_name)))))
2467         
2468     ;; Don't need any initialization for statement functions or
2469     ;; external functions
2470     ((or (member vble *external-function-names*)
2471          (member vble *subprog-stmt-fns*))
2472      ;;(format t "no declaration needed for ~A~%" vble)
2473      ;;(format t "stmt fns = ~A~%" *subprog-stmt-fns*)
2474      ;;(format t "ext fns  = ~A~%" *external-function-names*)
2475      ;;(format t "arglist  = ~A~%" *subprog-arglist*)
2476      nil
2477      )
2478     ;; check for declared variable
2479     ((member vble *declared_vbles*)
2480      ;;(format t "~a is declared~%" vble)
2481      (do ((type-clauses *explicit_vble_decls* (cdr type-clauses))
2482           (decl nil))
2483          ((null type-clauses) )
2484        (setq type (caar type-clauses))
2485        (cond ((and (listp type)
2486                    (eq (car type) 'character))
2487               (if (setq decl (member vble (cdar type-clauses) :key #'car))
2488                   (return (make-char-decl (car decl) type))))
2489              ((eq type 'array)
2490               (when (setq decl (member vble (cdar type-clauses) :key #'car))
2491                   (return `(declare (type (,*array-type*
2492                                            ,(get_array_type (caar decl)
2493                                                             vble-is-formal-arg)
2494                                            ,(f2cl-array-total-size (cdar decl))
2495                                            )
2496                                      ,vble_name)))
2497                   ))
2498              ((eq type 'logical)
2499               (if (setq decl (member vble (cdar type-clauses) :key #'car))
2500                   (return
2501                     (if (cdar decl)
2502                         `(declare (type (,*array-type* logical ,(f2cl-array-total-size (cdar decl)))
2503                                    ,vble_name))
2504                         `(declare (type logical ,vble))))))
2505              (t
2506               (when (setq decl (member vble (cdar type-clauses) :key #'car))
2507                 ;;(format t "declared vble ~A = ~A~%" vble parameterp)
2508                 (return
2509                   (cond ((cdar decl)
2510                          `(declare (type (,*array-type*
2511                                           ,type
2512                                           ,(f2cl-array-total-size (cdar decl)))
2513                                          ,vble_name)))
2514                         (t
2515                          (let ((limit (when parameterp
2516                                         `(,parameterp ,parameterp))))
2517                          `(declare (type (,type ,@limit) ,vble_name)))))))))))
2518     ;; check implicitly declared variable.  (Why do we check to see
2519     ;; if the var is a formal arg?  What difference does that make
2520     ;; here?  I'm taking it out.)
2521     ((and #+nil (not vble-is-formal-arg)
2522           (setq type (get-implicit-type vble)))
2523      ;;(format t "implicit decl~%")
2524      (if (and (listp type) (eq (car type) 'character))
2525          (make-char-decl (list vble_name) type)
2526          (progn
2527            (when (eq type :none)
2528              (warn "Undeclared variable `~A' with no implicit type!" vble))
2529            `(declare (type ,type ,vble_name)))))
2530     ;; otherwise use default declaration
2531     (t
2532      (let ((limit (when parameterp
2533                     `(,parameterp ,parameterp))))
2534        ;;(format t "default decl ~A, limit = ~A~%" vble limit)
2535        (if (default-int-p vble)
2536            `(declare (type (integer4 ,@limit) ,vble_name))
2537            `(declare (type (,(maybe-promote-type 'single-float) ,@limit) ,vble_name)))))))))
2538
2539(defun make-char-decl (decl type)
2540  (flet ((decl-bounds (bounds)
2541           (let ((dims
2542                  (mapcar #'(lambda (b)
2543                              (destructuring-bind (lo hi)
2544                                  b
2545                                (if (and (numberp lo) (numberp hi))
2546                                    (+ 1 (- hi lo))
2547                                    '*)))
2548                          bounds)))
2549             (cond ((every #'numberp dims)
2550                    (list (reduce #'* dims)))
2551                   ((= 1 (length bounds))
2552                    '(*))
2553                   (t
2554                    '*)))))
2555    (cond ((null (cdr decl))
2556           ;; scalar, no length spec.
2557           ;;(format t "scalar, no length spec = ~A~%" decl)
2558           (if (equal (cadr type) '(*))
2559               `(declare (type (simple-string) ,(car decl)))   
2560               `(declare (type (simple-string ,(cadr type)) ,(car decl)))))
2561          ((atom (cadr decl))
2562           ;; scalar, length spec.
2563           ;;(format t "scalar, length spec = ~A~%" decl)
2564           (error "shouldn't happen!")
2565           ;;`(declare (type (simple-array base-char (,(cadr decl))) ,(car decl)))
2566           )
2567          ((equal (cadr decl) '(*))
2568           ;; unspecified length spec
2569           ;;(format t "unspecified length spec = ~A~%" decl)
2570           `(declare (type (simple-string) ,(car decl))))
2571          (t
2572           ;; array, no length spec.
2573           ;;(format t "array, no length spec = ~A~%" decl)
2574           ;;(format t "type = ~S~%" type)
2575           ;;(format t "decl-bounds = ~S~%" (decl-bounds (rest decl)))
2576           `(declare (type (,*array-type*
2577                            (string ,(if (second type)
2578                                                         (second type)
2579                                                         '*))
2580                            ,(decl-bounds (rest decl))) ,(car decl)))))))
2581
2582(defun make-char-init (decl type &optional init)
2583  (cond ((equal (cadr type) '(*))       ; unspecified length spec
2584         ;;(format t "make-char-init unspecified length spec (*)~%")
2585         "")
2586        ((null (cdr type))              ; scalar, no length spec.
2587         (format t "make-char-init scalar, no length~%")
2588         `(make-array '(,(cadr type)) :element-type 'character :initial-element #\Space))
2589        ((atom (cadr decl))             ; scalar, length spec.
2590         ;;(format t "scalar, length spec~%")
2591         (if init
2592             (if (= (length init) (cadr type))
2593                 `(make-array '(,(cadr type)) :element-type 'character
2594                              :initial-contents ,init)
2595                 `(replace (make-array '(,(cadr type)) :element-type 'character
2596                                       :initial-element #\space)
2597                           ,init))
2598             `(make-array '(,(cadr type)) :element-type 'character
2599                          :initial-element #\space)))
2600        (t                              ; array, no length spec.
2601         ;;(format t "make-char-init array, no length spec~%")
2602         (let ((dims (mapcar #'(lambda (bounds)
2603                                 (destructuring-bind (lo hi)
2604                                     bounds
2605                                   (if (and (numberp lo) (numberp hi))
2606                                       (+ 1 (- hi lo))
2607                                       `(+ 1 (- ,hi ,lo)))))
2608                             (remove '|,| (rest decl)))))
2609           ;;(format t "dims = ~A~%" dims)
2610           `(f2cl-init-string ,dims ,(cdr type) ,init)))))
2611
2612
2613(defun get-implicit-type (vble)
2614  (do ((decls *implicit_vble_decls* (cdr decls))
2615       (vble-str (aref (string vble) 0)))
2616      ((null decls) nil)
2617    (if
2618     (do ((vble-ranges (cdar decls) (cdr vble-ranges)))
2619         ((null vble-ranges) nil)
2620       (if (or (and (cdar vble-ranges)
2621                    (string>= vble-str (string (caar vble-ranges)))
2622                    (string<= vble-str (string (cadar vble-ranges))))
2623               (string= vble-str (string (caar vble-ranges))))
2624           (return t)))
2625     (return (caar decls)))))
2626
2627
2628#+nil
2629(defun get_array_type (decl vble-is-formal-arg)
2630  (prog (type)
2631      (return
2632       (cond ((and (member decl *common_array_dims*)
2633                   (setq type (car (member decl *explicit_vble_decls* :key #'caadr)))
2634                   (not (eq (car type) 'array)))
2635              (car type))
2636             ((setq type (get-implicit-type decl))
2637              type)
2638             ((default-int-p decl)
2639              'integer4)
2640             (t
2641              'single-float)))))
2642
2643(defun get_array_type (decl vble-is-formal-arg)
2644  (prog (type)
2645      (return
2646       (cond ((member decl *common_array_dims*)
2647              (lookup-vble-type decl))
2648             ((setq type (get-implicit-type decl))
2649              type)
2650             ((default-int-p decl)
2651              'integer4)
2652             (t
2653              (maybe-promote-type 'single-float))))))
2654
2655(defun default-int-p (vble)
2656   (and (string>= (string vble) (symbol-name :i))
2657        (string< (string vble) (symbol-name :o))))
2658
2659;; Test whether or not a given symbol has been defined as an array.
2660(defun vble-is-array-p (v)
2661  ;;(format t "common_array_dims = ~A~%" *common_array_dims*)
2662  ;;(format t "declard_vbles     = ~A~%" *declared_vbles*)
2663
2664  ;; If it's an explicitly declared name, look through the
2665  ;; declarations to see if there are dimensions associated.
2666  ;;
2667  ;; If it's not, try to see if it's in the list of comman arrays that
2668  ;; have been dimensioned.
2669  ;;
2670  ;; ### This is pretty gross!  Why can't we keep this info all in one
2671  ;; place?
2672  (when (member v *declared_vbles*)
2673    (do ((decls *explicit_vble_decls* (cdr decls)))
2674        ((null decls) nil)
2675      (if (do ((vbles (cdar decls) (cdr vbles)))
2676              ((null vbles) nil)
2677            (if (and (eq v (caar vbles)) (cdar vbles))
2678                (return-from vble-is-array-p t)))
2679          (return-from vble-is-array-p t))))
2680  ;; else check if v is a common variable and an array or has 2 declarations
2681  (or (member v *common_array_dims*)
2682      (vble-declared-twice-p v *explicit_vble_decls*)))
2683
2684
2685
2686; test if a symbol is a function call rather than an undeclared vble
2687; used in check_new_vbles
2688(defun sym-is-fun-name (expr)
2689   (and (listp (cadr expr)) (not (null (cdr expr)))))
2690
2691;; Test if a symbol is really an f2cl hacked number.  This only
2692;; happens when the number is in exponential form with a negative
2693;; exponent.
2694(defun sym-is-number-p (expr)
2695  (let* ((s (string expr))
2696         (neg (position #\% s)))
2697    (when neg
2698      ;; Ok, it might be a f2cl hacked number which looks something like
2699      ;;
2700      ;; m.mmmD%xx Make sure the character before "%" is D or E, and
2701      ;; then make sure that the stuff before the exponent and after
2702      ;; the "%" is a valid number.
2703      (and neg
2704           (plusp neg)
2705           (member (aref s (1- neg)) '(#\d #\D #\e #\E) :test #'char-equal)
2706           (numberp (read-from-string (subseq s 0 (1- neg))))
2707           (numberp (read-from-string (subseq s (1+ neg))))))))
2708     
2709; given a list of variables names proclaim them special
2710(defun make-special-proclamation (vars)
2711   (if vars `(proclaim '(special ,@vars)) nil))
2712
2713; declare a special (common) variable
2714(defun make-special-var-decl (v)
2715  (let ((dim (member v *common_array_dims*)))
2716    (cond                               ; check if v is an array
2717      (dim
2718       `(declare (type (,*array-type* ,(get_array_type v nil)
2719                        ,(f2cl-array-total-size (cadr dim)))
2720                  ,(check-reserved-lisp-names v))))
2721                                        ; else make ordinary declaration
2722      (t (make-declaration v)))))
2723
2724(defparameter +reserved-lisp-names+
2725  '(t pi nil))
2726
2727(defparameter +allowed-lisp-names+
2728  '(abs sin cos tan
2729    asin acos atan
2730    sinh cosh tanh
2731    exp max min
2732    mod))
2733
2734;; Check if the Fortran name would collide with Lisp names like T, PI,
2735;; NIL, FUNCALL, PROG, etc.  If it does, replace it a new name
2736
2737(defun check-reserved-lisp-names (x)
2738  (multiple-value-bind (found-it access)
2739      (find-symbol (string x) :common-lisp)
2740    (cond ((or (member x +allowed-lisp-names+)
2741               (member x '(d1mach i1mach %false% %true%)))
2742           ;; Don't want to mangle allowed-lisp-names or some special
2743           ;; symbols from f2cl or f2cl-lib.
2744           x)
2745          ((or (and found-it
2746                    (not (eq access :internal))
2747                    (fboundp found-it))
2748               (member x +reserved-lisp-names+)
2749               (eq :external (nth-value 1 (find-symbol (symbol-name x) :f2cl-lib))))
2750           ;; We want to append "$" for certain cases to prevent
2751           ;; collisions.  (Any character can be used.  But we can't
2752           ;; prepend because f2cl wants to look at the first
2753           ;; character to determine the default variable type.)
2754           ;;
2755           ;; 1. External functions in the common-lisp package.
2756           ;;
2757           ;; 2. External symbols in the f2cl-lib package.  (Not
2758           ;;    strictly necessary, but does make the code nicer).
2759           (intern (concatenate 'string (string x) "$")))
2760          (t
2761           x))))
2762
2763;-----------------------------------------------------------------------------     
2764; functions for fixing DO and IF structures
2765
2766; sort out do loops and if-then-else structures
2767(defun fix-structure (checklist labels) ; labels is the do labels
2768   (do ((retlist (list (third checklist) (second checklist) (first checklist))
2769                 (if clause (cons clause retlist) retlist))
2770        (exprs (cdddr checklist))
2771        (clause))
2772       ((null exprs) (reverse retlist))
2773       (cond ((listp (car exprs))
2774              (cond ((eq (caar exprs) 'if-then)
2775                     (multiple-value-setq (clause exprs)
2776                                          (fix-ifthen exprs labels)))
2777                    ((eq (caar exprs) 'fdo)
2778                     (multiple-value-setq (clause exprs) (fix-do exprs labels)))
2779                    ((eq (caar exprs) 'continue_place_holder)
2780                     (setq clause nil
2781                           exprs (cdr exprs)))
2782                    (t (setq clause (car exprs)
2783                             exprs (cdr exprs)))))
2784            ((eq (car exprs) 'continue_place_holder)
2785              (setq clause nil
2786                    exprs (cdr exprs)))
2787            (t (setq clause (car exprs)
2788                     exprs (cdr exprs))))))
2789
2790(defun fix-ifthen (checklist labels)
2791    (do ((clause (cdar checklist))
2792         (exprs (cdr checklist))
2793         (ret nil) (subclause))
2794        ((eq (car exprs) 'endif_place_holder)
2795         (setq ret (cons (reverse clause) ret))
2796         (values (append '(cond) (fix-tagbodies (reverse ret))) (cdr exprs)))
2797        (cond ((listp (car exprs))
2798               (cond ((eq (caar exprs) 'fdo)
2799                      (multiple-value-setq (subclause exprs)
2800                                           (fix-do exprs labels))
2801                      (setq clause (cons subclause clause)))
2802                     ((eq (caar exprs) 'if-then)
2803                      (multiple-value-setq (subclause exprs)
2804                                           (fix-ifthen exprs labels))
2805                      (setq clause (cons subclause clause)))
2806                     ((eq (caar exprs) 'elseif_place_holder)
2807                      (setq ret (cons (reverse clause) ret)
2808                            clause (list (cadar exprs))
2809                            exprs (cdr exprs)))
2810                     (t (setq clause (cons (car exprs) clause)
2811                              exprs (cdr exprs)))))
2812              ((eq (car exprs) 'continue_place_holder)
2813               (setq exprs (cdr exprs)))
2814              (t (setq clause (cons (car exprs) clause)
2815                       exprs (cdr exprs))))))
2816
2817
2818; compare FDO_BODY_LABELx with LABELy
2819; return t if x = y
2820(defun end-do-p (checklist do-label)
2821  (and (not (listp (car checklist)))
2822       (label-matches-dolabel-p (car checklist) do-label)))
2823
2824; given (go labelx) does it match with current fdo_body_labely
2825(defun label-matches-dolabel-p (label do_label)
2826   (and (eq 5 (string-lessp (symbol-name :label) (string label)))
2827        (equal (string-left-trim (symbol-name :label) label)
2828               (string-left-trim (symbol-name :fdo_body_label) do_label))))
2829
2830;------------------------------------------------------------------------------
2831
2832(defun fix-do (checklist labels)
2833  (do ((do-expr (ldiff (car checklist) (last (car checklist))) )
2834       (loop-body '(tagbody)
2835                  (if subclause (cons subclause loop-body) loop-body))
2836       (exprs (cdr checklist))
2837       (subclause nil)
2838       (do-label (car (last (car checklist)))))
2839
2840      ((or (null exprs)
2841           (end-do-p exprs do-label))
2842       (cond
2843         ((null exprs)
2844          (error "A DO statement without a matching label?!"))
2845         ((multiple-do-labelp (car exprs) labels)
2846          ;; Sometimes we get duplicated labels, so remove them.  Is
2847          ;; REMOVE-DUPLICATES to general?  Should we be more careful?
2848          (setf loop-body (remove-duplicates loop-body))
2849          (values (append do-expr
2850                          (list (reverse loop-body))) exprs))
2851
2852         ((not (eq (second exprs) 'continue_place_holder))
2853          (values (append do-expr
2854                          (list
2855                           (reverse (cons (second exprs)
2856                                          (cons (intern (remove-prefix do-label)) loop-body)))))
2857                  (cddr exprs)))
2858         (t
2859          (values (append do-expr
2860                          (list
2861                           (reverse (cons (intern (remove-prefix do-label)) loop-body))))
2862                  (cddr exprs))) ))
2863    ;; body
2864    (cond ((listp (car exprs))
2865           (cond ((eq (caar exprs) 'if-then)
2866                  (multiple-value-setq (subclause exprs)
2867                    (fix-ifthen exprs labels)))
2868                 ((eq (caar exprs) 'fdo)
2869                  (multiple-value-setq (subclause exprs)
2870                    (fix-do exprs labels)))
2871                 ((and (eq (caar exprs) 'go)
2872                       (label-matches-dolabel-p (cadar exprs) do-label))
2873                  ;; Why do we treat a go to to the continue
2874                  ;; statement of the do loop differently?  Why
2875                  ;; "(return)" instead of "(go label)"
2876                  #+nil
2877                  (setq subclause '(return)
2878                        exprs (cdr exprs))
2879                  (setq subclause (car exprs)
2880                        exprs (cdr exprs)))
2881                 (t (setq subclause (car exprs)
2882                          exprs (cdr exprs)))))
2883          ((eq (car exprs) 'continue_place_holder)
2884           ;; Not really sure about this.  Basically we look to find
2885           ;; the next label, and make that the label for our do-loop.
2886           #+(or)
2887           (progn
2888             (format t "continue_place_holder~%")
2889             (format t "cdr exprs = ~S~%" (cdr exprs)))
2890           (let ((clabel
2891                  (dolist (item (cdr exprs))
2892                    (unless (symbolp item)
2893                      ;; Once an item isn't a symbol, our label can't
2894                      ;; appear later, so give up.
2895                      (return nil))
2896                    (when (search (string '#:label)
2897                                       (string item))
2898                      ;;(format t "continue label = ~S~%" item)
2899                      (return item)))))
2900
2901             ;; We only want clabel if there are do loops with the
2902             ;; same end label.  Otherwise, everything is ok.
2903             (setq subclause (if (multiple-do-labelp clabel labels)
2904                                 clabel
2905                                 nil)
2906                   exprs (cdr exprs))))
2907          (t (setq subclause (car exprs)
2908                   exprs (cdr exprs))))))
2909
2910(defun remove-prefix (x) (string-left-trim (symbol-name '#:fdo_body_) x))
2911
2912(defun multiple-do-labelp (labelnnn labels)
2913  (< 1 (length (remove-if-not #'(lambda (x)
2914                                  (label-matches-dolabel-p labelnnn
2915                                                           (princ-to-string x)))
2916                              labels))))
2917
2918;------------------------------------------------------------------------------
2919
2920; if a cond clause contains a jump (from within to within) make a tagbody
2921(defun fix-tagbodies (cond-expr)
2922   (do ((clauses cond-expr (cdr clauses))
2923        (new-clauses nil (cons clause new-clauses))
2924        (clause nil))
2925       ((null clauses) (reverse new-clauses))
2926       (setq clause (car clauses)) ;(<pred> expr expr ....)
2927       (if (member-if #'symbolp (cdr clause))
2928           (setq clause `(,(car clause) (tagbody ,@(cdr clause)))))))
2929
2930;-----------------------------------------------------------------------------
2931
2932(eval-when (compile load eval) 
2933  (proclaim '(special *format_stmts* *current_label* *SP* *dlist-flag*)))
2934
2935(defun parse-format (x)
2936  (prog (*SP*)
2937   (declare (special *SP*))
2938   (setq *SP* nil)
2939   (setq *format_stmts* (cons (list *current_label*
2940                                 (parse-format1 (cadr x)))
2941                            *format_stmts*)))
2942)
2943
2944;; x is of form: '(WRITE (* |,| 8000) |,| J |,| K)
2945;;           or  '(WRITE (*) |,| J |,| K)
2946;;           or  '(WRITE (* |,| *) |,| J |,| K)
2947;;
2948;; Note that the unit can be any arbitrary expression, so be careful.
2949
2950(defun parse-write (x)
2951  ;; check for comma before arguments
2952  (if (and (third x) (not (eq (third x) '|,|)))
2953      (setq x (append (list (first x) (second x) '|,|) (cddr x))))
2954  ;; As shown above, (second x) will contain the unit number and the
2955  ;; format number, if any.  Split this at the comma to get the unit
2956  ;; part and the format part.
2957  (destructuring-bind (lun-part fmt-part)
2958      (list-split '|,| (second x))
2959    ;;(format t "lun-part = ~A~%" lun-part)
2960    ;;(format t "fmt-part = ~A~%" fmt-part)
2961
2962    (let ((args (if (cdddr x)
2963                    (mapcar #'parse-output-argument
2964                            (list-split '|,| (cdddr x)))
2965                    nil)))
2966      ;; If there are no items to be written, make sure args is NIL,
2967      ;; so fformat knows there are no items.
2968      `((fformat ,(parse_format_dest lun-part)
2969                 ,(if (null fmt-part)
2970                      '(("~A~%"))
2971                      (get_format_stmt fmt-part))
2972                 ,@args)))))
2973
2974;; x is of the form: '(PRINT * |,| X |,| Y)
2975;;               or: '(PRINT 9000 |,| X |,| Y)
2976
2977(defun parse-print (x)
2978  (let ((args (if (cdddr x)
2979                  (mapcar #'parse-output-argument
2980                          (list-split '|,| (cdddr x)))
2981                  nil)))
2982    ;; If there are no items to be written, make sure args is NIL,
2983    ;; so fformat knows there are no items.
2984    `((fformat t
2985               ,(get_format_stmt (list (second x)))
2986               ,@args))))
2987
2988;; x is of the form '(read (lun |,| format) var |,| var)
2989;;
2990;; We're not trying to implement full Fortran read functionality.  We
2991;; just want to read data into the variables.  Implied do loops are
2992;; not supported.
2993#+nil
2994(defun parse-read (x)
2995  (append (list '(fortran_comment "***WARNING:  READ statement may not be translated correctly!"))
2996          (mapcar #'(lambda (var)
2997                      `(setf ,(if (rest var)
2998                                  var
2999                                  (first var))
3000                        (read)))
3001                  (remove nil (list-split '|,| (cddr x))))
3002          (list '(fortran_comment "***WARNING: Preceding READ statements may not be correct!"))))
3003
3004;; x is of the form (read (lun , fmt) <var-or-implied-do>)
3005#+nil
3006(defun parse-read (x)
3007  (labels ((handle-simple-var (expr)
3008             (cond ((and (listp expr)
3009                         (eq (first expr) 'fref))
3010                    `(fset ,expr (read)))
3011                   ((and (symbolp expr)
3012                         (subtypep (lookup-vble-type expr) 'string))
3013                    `(f2cl-set-string ,expr (read) ,(lookup-vble-type expr)))
3014                   (t
3015                    `(setf ,expr (read)))))
3016           (handle-implied-do (do-list)
3017             ;; Like parse-implied-do
3018             (let* ((ctrl-vars (member-if #'(lambda (x) (eq (second x) '=)) do-list))
3019                    (dlist (parse-dlist (ldiff do-list ctrl-vars)))
3020                    (ivar (first (first ctrl-vars)))
3021                    (e1 (id-expression (cdr (member '= (first ctrl-vars)))))
3022                    (e2 (id-expression (second ctrl-vars)))
3023                    (e3 (if (third ctrl-vars) (third ctrl-vars) 1)))
3024               ;;(format t "do-list = ~A~%" do-list)
3025               ;;(format t "dlist = ~S~%" dlist)
3026               ;;(format t "*dlist-flag* = ~A~%" *dlist-flag*)
3027               `(do ((,ivar ,e1 (+ ,ivar ,e3)))
3028                        ((> ,ivar ,e2))
3029                      (declare (type integer4 ,ivar))
3030                      ,@(mapcar #'(lambda (v)
3031                                    `(fset ,v (read)))
3032                                (cdr dlist)))))
3033           (handle-var (arg)
3034             (cond ((null arg) nil)
3035                   ((and (listp arg)
3036                         (listp (car arg))
3037                         (member '= (car arg)))
3038                    ;; Implied do
3039                    (handle-implied-do (list-split '|,| (car arg))))
3040                   (t
3041                    (handle-simple-var (id-expression arg))))))
3042    (append (list '(fortran_comment "***WARNING:  READ statement may not be translated correctly!"))
3043            (mapcar #'handle-var
3044                    (remove nil (list-split '|,| (cddr x))))
3045            (list '(fortran_comment "***WARNING: Preceding READ statements may not be correct!")))))
3046
3047(defun parse-read (x)
3048  (let* ((read-opts (list-split '|,| (second x)))
3049         (lun (caar read-opts)))
3050    ;;(format t "read-opts = ~S~%" read-opts)
3051    ;;(format t "vars = ~S~%" (cddr x))
3052    (labels ((handle-simple-var (expr)
3053               (cond ((and (listp expr)
3054                           (eq (first expr) 'fref))
3055                      `(fset ,expr (read (f2cl-lib::lun->stream ,lun))))
3056                     ((and (symbolp expr)
3057                           (subtypep (lookup-vble-type expr) 'string))
3058                      `(f2cl-set-string ,expr (read (f2cl-lib::lun->stream ,lun))
3059                                        ,(lookup-vble-type expr)))
3060                     (t
3061                      (check_new_vbles expr)
3062                      `(setf ,expr (read (f2cl-lib::lun->stream ,lun))))))
3063             (handle-implied-do (do-list)
3064               ;; Like parse-implied-do
3065               (let* ((ctrl-vars (member-if #'(lambda (x) (eq (second x) '=)) do-list))
3066                      (dlist (parse-dlist (ldiff do-list ctrl-vars)))
3067                      (ivar (first (first ctrl-vars)))
3068                      (e1 (id-expression (cdr (member '= (first ctrl-vars)))))
3069                      (e2 (id-expression (second ctrl-vars)))
3070                      (e3 (if (third ctrl-vars) (third ctrl-vars) 1)))
3071                 ;;(format t "do-list = ~A~%" do-list)
3072                 ;;(format t "dlist = ~S~%" dlist)
3073                 ;;(format t "*dlist-flag* = ~A~%" *dlist-flag*)
3074                 `(do ((,ivar ,e1 (+ ,ivar ,e3)))
3075                      ((> ,ivar ,e2))
3076                    (declare (type integer4 ,ivar))
3077                    ,@(mapcar #'(lambda (v)
3078                                  `(fset ,v (read (f2cl-lib::lun->stream ,lun))))
3079                              (cdr dlist)))))
3080             (handle-var (arg)
3081               (cond ((null arg) nil)
3082                     ((and (listp arg)
3083                           (listp (car arg))
3084                           (member '= (car arg)))
3085                      ;; Implied do
3086                      (handle-implied-do (list-split '|,| (car arg))))
3087                     (t
3088                      (handle-simple-var (id-expression arg))))))
3089      ;; Only handle the simple case of read(<lun>,...)
3090      (append (list '(fortran_comment "***WARNING:  READ statement may not be translated correctly!"))
3091              (mapcar #'handle-var
3092                      (remove nil (list-split '|,| (cddr x))))
3093              (list '(fortran_comment "***WARNING: Preceding READ statements may not be correct!"))))))
3094 
3095
3096;; x is (OPEN (lun |,| <open-keywords)
3097;;   or (OPEN (unit = <x> |,| <open-keywords>))
3098(defun parse-open (x)
3099  (let ((options (list-split '|,| (second x))))
3100    (when (= (length (car options)) 1)
3101      ;; We have just a unit number, instead of "unit = lun".  Convert
3102      ;; it to the latter form.
3103      (setf (car options) `(unit = ,(caar options))))
3104    ;; Convert the list of options into Lisp-style keyword options.
3105    (let ((res nil))
3106      (dolist (opt options)
3107        (destructuring-bind (key = &rest val)
3108            opt
3109          (declare (ignore =))
3110          ;; Convert the key into a keyword, and parse the value since
3111          ;; it can be an arbitrary expression.  (Well, not always,
3112          ;; but we're not going to check for that because that's not
3113          ;; valid Fortran.
3114          (push (intern (string-upcase (string key)) :keyword) res)
3115          (push (parse-expression val) res)))
3116      (setf res (nreverse res))
3117      `((f2cl-lib::open-file ,@res)))))
3118
3119(defun parse-rewind (x)
3120  (let ((options (if (listp (second x))
3121                     (flatten-list
3122                      (mapcar #'(lambda (opt)
3123                                  (destructuring-bind (key = val)
3124                                      opt
3125                                    (declare (ignore =))
3126                                    `(,(intern (string-upcase (string key)) :keyword)
3127                                       ,val)))
3128                              (list-split '|,| (second x))))
3129                     `(:unit ,(second x)))))
3130    `((f2cl-lib::rewind ,@options))))
3131
3132(defun parse-close (x)
3133  (let ((options (if (= (length (second x)) 1)
3134                     `(:unit ,(first (second x)))
3135                     (flatten-list
3136                      (mapcar #'(lambda (opt)
3137                                  (destructuring-bind (key = val)
3138                                      opt
3139                                    (declare (ignore =))
3140                                    `(,(intern (string-upcase (string key)) :keyword)
3141                                       ,val)))
3142                              (list-split '|,| (second x)))))))
3143    `((f2cl-lib::close$ ,@options))))
3144
3145;; Get the appropriate format string.
3146;;
3147;; LABEL is the label portion of a WRITE statement, and is one of the
3148;; following forms:
3149;;
3150;; (<number>)
3151;; (*)
3152;; (FMT = <number>) or (FMT = *)
3153;; (FMT = <string>)
3154(defun get_format_stmt (label)
3155  (let ((fmt-num (first label)))
3156    (cond ((eq fmt-num 'fmt)
3157           ;; We have something like "FMT = number".  Pretend it was
3158           ;; just "number" and look up the format string.
3159           (get_format_stmt (list (third label))))
3160          ((stringp fmt-num)
3161           ;; We have something like FMT = "string".  Process the
3162           ;; format string and return the result.
3163           (let ((*sp* nil)
3164                 (fmt (with-fortran-syntax
3165                        (lineread
3166                         (make-string-input-stream
3167                          (process-format-line
3168                           fmt-num))))))
3169             (declare (special *sp*))
3170             (parse-format1 (brackets-check (concat-operators fmt)))))
3171          ((or (eq fmt-num '*)
3172               (not (numberp fmt-num)))
3173           ;; List-directed output
3174           :list-directed)
3175          (t
3176           (do ((lis *format_stmts* (cdr lis)))
3177               ((null lis)
3178                (error "Format statement ~A not found" fmt-num))
3179             (if (equal fmt-num (caar lis))
3180                 (return (cadar lis))))))))
3181
3182;; Figure out where we're trying to WRITE to.
3183;;
3184;; DEST can be any arbitrary expression, so we need to parse it.
3185(defun parse_format_dest (dest)
3186  (cond ((null (rest dest))
3187         (if (eq (first dest) '*) t (first dest)))
3188        (t
3189         (id-expression dest))))
3190
3191(defun parse-output-argument (arg)
3192   (cond ((null arg) nil)
3193         ((and (listp arg) (listp (car arg)) (member '= (car arg)))  ;implied-do
3194          (parse-implied-DO (list-split '|,| (car arg))))
3195         ((and (listp arg) (every #'listp arg)) ; dlist
3196          (parse-dlist arg))
3197         (t (id-expression (check_new_vbles arg)))))
3198
3199#+nil
3200(defun parse-implied-do (do-list)
3201   (prog (ctrl-vars dlist ivar e1 e2 e3 (*dlist-flag* nil))
3202      (setq ctrl-vars (member-if #'(lambda (x) (eq (second x) '=)) do-list)
3203            dlist (parse-dlist (ldiff do-list ctrl-vars))
3204            ivar (first (first ctrl-vars))
3205            e1 (id-expression (cdr (member '= (first ctrl-vars))))
3206            e2 (id-expression (second ctrl-vars))
3207            e3 (if (third ctrl-vars) (third ctrl-vars) 1))
3208      (return
3209      (if *dlist-flag*
3210      `(do ((,ivar ,e1 (+ ,ivar ,e3))
3211            (ret nil (append ret ,dlist)))
3212           ((> ,ivar ,e2) ret)
3213        (declare (type integer4 ,ivar)))
3214
3215      `(do ((,ivar ,e1 (+ ,ivar ,e3))
3216            (ret nil (cons ,dlist ret)))
3217           ((> ,ivar ,e2) (reverse ret))
3218         (declare (type integer4 ,ivar)))))))
3219
3220(defun parse-implied-do (do-list)
3221  (flet ((map-items (items)
3222           (mapcar #'(lambda (x)
3223                        `(push ,x %ret))
3224                items)))
3225  (prog (ctrl-vars dlist ivar e1 e2 e3 (*dlist-flag* nil))
3226     (setq ctrl-vars (member-if #'(lambda (x) (eq (second x) '=)) do-list)
3227           dlist (parse-dlist (ldiff do-list ctrl-vars))
3228           ivar (first (first ctrl-vars))
3229           e1 (id-expression (cdr (member '= (first ctrl-vars))))
3230           e2 (id-expression (second ctrl-vars))
3231           e3 (if (third ctrl-vars)
3232                  (id-expression (third ctrl-vars))
3233                  1))
3234     (return
3235       (if *dlist-flag*
3236           `(do ((,ivar ,e1 (+ ,ivar ,e3))
3237                 (%ret nil))
3238                ((> ,ivar ,e2)
3239                 (nreverse %ret))
3240              (declare (type integer4 ,ivar))
3241              ,@(map-items (cdr dlist)))
3242
3243           `(do ((,ivar ,e1 (+ ,ivar ,e3))
3244                 (%ret nil (cons ,dlist %ret)))
3245                ((> ,ivar ,e2) (reverse %ret))
3246              (declare (type integer4 ,ivar))))))))
3247
3248(defun parse-dlist (x)
3249   (setq *dlist-flag* t)
3250   `(list ,@(mapcar #'parse-output-argument x)))
3251
3252;--------------------------------------------------------------------------------
3253
3254; convert an array to a list
3255; this is possibly implementation dependent
3256; but is not actually used by the translator
3257(defun array-list (array)
3258  (prog (str i dim old-print-length old-print-level old-print-array)
3259   (setq old-print-array *print-array*
3260         old-print-length *print-length*
3261         old-print-level *print-level*
3262         *print-array* t
3263         *print-length* nil
3264         *print-level* nil)
3265   (setq str (princ-to-string array)
3266         dim (length str))
3267   (setq i (do ((i 0 (1+ i)))
3268               ((eq (schar str i) #\() i)))
3269   (setq str
3270         (read-from-string (make-array (- dim i) :displaced-to str
3271                                                 :displaced-index-offset i
3272                                                 :element-type 'character)))
3273   (setq *print-array* old-print-array
3274         *print-length* old-print-length
3275         *print-level* old-print-level)
3276   (return str)))
3277
3278;--------------------------------------------------------------------------------
3279
3280(defun parse-format1 (format &optional (newlinep t))
3281  (let ((x (list-split '|,| (fix-slashes format)))
3282        *scale-factor*)
3283    (declare (special *scale-factor*))
3284    ;; It's valid to have a format like "1p,e15.8" instead of
3285    ;; "1pe15.8".  So the variable *scale-factor* is used to handle
3286    ;; this case.  The parser for P sets *scale-factor* appropriately
3287    ;; for use by other edit descriptors.
3288    (do ((desc-lists x (cdr desc-lists))
3289         (directive) (dl)
3290         (directive-list nil (append directive-list directive)))
3291        ((null desc-lists)
3292         (if newlinep
3293             (append directive-list '("~%"))
3294             directive-list))
3295      (setq dl (car desc-lists))
3296      (setq directive
3297            (cond ((null dl) nil)       ;(list nil))
3298                  ((stringp (car dl))
3299                   (list (car dl)))
3300                  ((listp (car dl))
3301                   ;; Repeat group forever, as signaled by the rep factor of T.
3302                   (append  '(t) (list (parse-format1 (car dl) nil))))
3303                  ((and (numberp (car dl))
3304                        (listp (cadr dl)))
3305                   ;; Repetition of a group
3306                   (append (list (car dl))
3307                           (list (parse-format1 (cadr dl) nil))))
3308                  ((numberp (car dl))
3309                   ;; Simple repeated format descriptor (Handles the
3310                   ;; case where the repetition factor is separated
3311                   ;; from the format descriptor.  The case when the
3312                   ;; repetition factor is NOT separated is handled
3313                   ;; below.
3314                   (parse-format-descriptor-list (car dl)
3315                                                 (destruct-descriptor-list (cdr dl))))
3316                  (t (parse-format-descriptor-list 1
3317                                                   (destruct-descriptor-list dl))))))))
3318
3319;--------------------------------------------------------------------------------
3320
3321;;; Given a symbol e.g I4 or P2G10.4E2 this function seperates it into
3322;;; numbers and symbols eg (#\I 4) or (#\P 2 #\G 10 4 #\E 2).  The characters
3323;;; are converted to upper case.
3324
3325(defun destruct-descriptor-list (x)
3326  (let (descriptor-list char atm)
3327    (cond ((listp x)
3328           (setq x (make-string-input-stream
3329                    (reduce #'(lambda (r s)
3330                                (concatenate 'string r " " s))
3331                            (mapcar #'symbol-name x)))))
3332          ((symbolp x)
3333           (setq x (make-string-input-stream (symbol-name x))))
3334          (t
3335           (return-from destruct-descriptor-list x)))
3336    (loop
3337        (setq char (peek-char nil x nil :eof nil))
3338        (when (equal char :eof)
3339          (return-from destruct-descriptor-list (reverse descriptor-list)))
3340      (cond ((or (digit-char-p char)
3341                 (member char '(#\+ #\-)))
3342             (multiple-value-setq (atm x)
3343               (read-number-from-stream x)))
3344            ((eq char #\.)
3345             (read-char x)
3346             (setq atm nil))
3347            (t
3348             (setq atm (char-upcase (read-char x)))))
3349      (when atm
3350        (setq descriptor-list (cons atm descriptor-list))))))
3351
3352(defun read-number-from-stream (x)
3353   (prog ((number-str "") char)
3354     loop
3355   (setq char (peek-char nil x nil 'eof nil))
3356   (if (equal char 'eof) (return (values (read-from-string number-str) x)))
3357   (if (or (digit-char-p char) (member char '(#\+ #\-)))
3358       (setq number-str (concatenate `string number-str (string (read-char x))))
3359       (return (values (read-from-string number-str) x)))
3360   (go loop)))
3361
3362;--------------------------------------------------------------------------------
3363; pattern matching functions adapted from those in f3.l
3364
3365; bind matched atoms to A etc if the pattern has (> A)
3366; bind matched groups of atoms to B if the pattern has (+ B)
3367; the eval obtains the list of atoms seen so far and the cons adds the atom
3368; matched at the current level
3369; e.g. > (setq x  '(#\P 2 #\G 10 4 #\E 2))
3370;      > (pattern-match-and-bind '((+ left) #\G (+ right)) x)
3371;      binds (#\P 2) to left and (10 4 #\E 2) to right
3372;      > (pattern-match-and-bind '(#\P (> A) #\G (> B) (> C) (+ D)) x)
3373;      binds 2 to A, 10 to B, 4 to C and '(#\E 2) to D
3374
3375(defun pattern-match-and-bind (p d)
3376      (cond ((and (null p) (null d)) t)
3377            ((or (null p) (null d)) nil)   
3378            ((or (equal (car p) '>)       
3379                 (equal (car p) (car d)))
3380             (pattern-match-and-bind (cdr p) (cdr d)))
3381           
3382            ((and (listp (car p))
3383                  (equal (caar p) '>) 
3384                  (pattern-match-and-bind (cdr p) (cdr d)))
3385             (set (cadar p) (car d)) t)
3386            ((equal (car p) '+)                 
3387             (cond ((pattern-match-and-bind (cdr p) (cdr d)))   
3388                   ((pattern-match-and-bind p (cdr d)))))
3389            ((and (listp (car p))
3390                  (equal (caar p) '+))
3391             (cond ((pattern-match-and-bind (cdr p) (cdr d))
3392                    (set (cadar p) (list (car d))) t) ; building begins
3393                   ((pattern-match-and-bind p (cdr d))
3394                    (set (cadar p)
3395                         (cons (car d) (eval (cadar p)))) t)))))
3396
3397;;--------------------------------------------------------------------------------
3398;; functions for parsing format stmts which are stored with their labels
3399;; on a global list (referenced by calls to WRITE)
3400
3401(defun parse-format-descriptor-list (a x)
3402  (let ((matched-p nil)
3403        left right)
3404    (declare (special left right *scale-factor*))
3405    (if (numberp (car x))
3406        nil
3407        (setq x (cons a x)))
3408    ;; find most significant descriptor and parse
3409    (let ((result
3410           (cond
3411             ;;((typep (cdr x) 'string)
3412             ;; (cdr x))
3413             ((pattern-match-and-bind '((+ left) #\H (+ right)) x)
3414              (parse-format-descriptor-H left right))
3415             ((pattern-match-and-bind '((> left) #\I (+ right)) x)
3416              (parse-format-descriptor-I left right))
3417             ((pattern-match-and-bind '((> left) #\L (+ right)) x)
3418              (parse-format-descriptor-L left right))
3419             ((pattern-match-and-bind '((+ left) #\F (+ right)) x)
3420              (parse-format-descriptor-F left right))
3421             ((pattern-match-and-bind '((+ left) #\G (+ right)) x)
3422              (parse-format-descriptor-G left right))
3423             ((pattern-match-and-bind '((+ left) #\E (+ right)) x)
3424              (parse-format-descriptor-E left right))
3425             ((pattern-match-and-bind '((+ left) #\D (+ right)) x)
3426              (parse-format-descriptor-D left right))
3427             ((pattern-match-and-bind '((> left) #\T #\R (+ right)) x)
3428              (parse-format-descriptor-TR right))
3429             ((pattern-match-and-bind '((> left) #\X) x)
3430              (parse-format-descriptor-X left))
3431             ((pattern-match-and-bind '((> left) #\P) x)
3432              (setf matched-p t)
3433              (parse-format-descriptor-P left))
3434             ((pattern-match-and-bind '((> left) #\S (> right)) x)
3435              (parse-format-descriptor-S right))
3436             ((pattern-match-and-bind '((> left) #\A (+ right)) x)
3437              (parse-format-descriptor-A left right))
3438             ((equal (cadr x) '#\/)
3439              (parse-format-descriptor-/))
3440             ((equal (cadr x) #\:)
3441              ;; The colon descriptor terminates format control if
3442              ;; there are no more items in the input/output list.
3443              '(#\:))
3444             (t (parse-default-format-descriptor x)))))
3445      (unless matched-p
3446        ;; Need to reset *scale-factor* if this wasn't a P descriptor.
3447        (setf *scale-factor* nil))
3448      result)))
3449
3450(defun fixnum-string (x)
3451   (princ-to-string x))
3452
3453(defun parse-format-descriptor-A (a w)
3454  (let* ((width (if (listp w)
3455                   (car w)
3456                   w))
3457        (directive (list (format nil "~~~DA" width))))
3458    (list a (list directive))))
3459
3460;; Handle Fortran Iw.m format
3461(defun print-i-format (ostream val colonp at-sign-p width pad-width)
3462  (declare (ignore colonp at-sign-p))
3463  (let ((output (format nil "~V,'0D" width val)))
3464    ;; Converting leading zeros to blanks as needed
3465    (dotimes (k (- width pad-width))
3466      (setf (aref output k) #\space))
3467    (princ output ostream)
3468    (values)))
3469
3470(defun parse-format-descriptor-I (a w)
3471  ;; aIw.m
3472  ;;
3473  ;; According to the Fortran standard, if m is given, the output is
3474  ;; zero-padded on the left to occupy m positions.  In addition if m
3475  ;; = 0, and the number is 0, we aren't supposed to output
3476  ;; anything. We don't handle that here.  It's also unclear to me
3477  ;; what happens if m < w, but I think that means the number is
3478  ;; zero-padded to a width of m and printed right-justified in a
3479  ;; field of width w.
3480  (let* ((width (if (listp w)
3481                   (car w)
3482                   w))
3483        (directive (if (and (listp w) (second w))
3484                       (format nil "~~~D,~D/f2cl:print-i-format/" width (second w))
3485                       (format nil "~~~DD" width)
3486                       )))
3487    (list a (list (list directive)))))
3488
3489(defun parse-format-descriptor-L (a w)
3490  ;; aLw
3491  (let* ((width (if (listp w)
3492                   (car w)
3493                   w))
3494        (directive (if (and (listp w) (second w))
3495                       (format nil "~~~D,~D/f2cl:print-i-format/" width (second w))
3496                       (format nil "~~~D@A" width)
3497                       )))
3498    (list a (list (list directive)))))
3499
3500;<kP><a>Fw.d -> ~a{~w,d,k,,,[@]F}
3501(defun parse-format-descriptor-F (left right)
3502  (let ((k 0)
3503        (a 1))
3504    (declare (special k a *scale-factor*))
3505    (or (pattern-match-and-bind '((> k) #\P (> a)) left)
3506        (pattern-match-and-bind '((> k) #\P) left)
3507        (pattern-match-and-bind '((> a)) left))
3508    (when *scale-factor*
3509      (setf k *scale-factor*))
3510    (let ((directive
3511           (list (concatenate 'string
3512                              "~" (fixnum-string (car right)) "," ;w
3513                              (fixnum-string (cadr right)) "," ;d
3514                              (fixnum-string k) "," ;k
3515                              "'*,"
3516                              (if *SP* "@F" "F")))))
3517      (list a (list directive)))))
3518
3519;; Note: The Fortran standard says that, for a format like Ew.d, if
3520;; the the exponent is three digits long, the exponent indicator (E or
3521;; is not printed.  Thus instead of xxxE+ddd, we get xxx+ddd.  We
3522;; don't handle that here!
3523(defun parse-format-descriptor-E (left right)
3524  (let ((k 0) (a 1) w d (e 2))
3525    (declare (special k a w d e *scale-factor*))
3526    (or (pattern-match-and-bind '((> k) #\P (> a)) left)
3527        (pattern-match-and-bind '((> k) #\P) left)
3528        (pattern-match-and-bind '((> a)) left))
3529    (or (pattern-match-and-bind '((> w) (> d)) right)
3530        (pattern-match-and-bind '((> w) (> d) #\E (> e)) right))
3531    (when *scale-factor*
3532      (setf k *scale-factor*))
3533    (let ((directive
3534           (list (concatenate 'string
3535                              "~" (fixnum-string w) ","
3536                              (fixnum-string d) ","
3537                              (fixnum-string e) ","
3538                              (fixnum-string k) ",'*,,'E"
3539                              (if *SP* "@E" "E")))))
3540      (list a (list directive)))))
3541
3542(defun parse-format-descriptor-D (left right)
3543  (let ((k 0) (a 1) w d (e 2))
3544    (declare (special k a w d e *scale-factor*))
3545    (or (pattern-match-and-bind '((> k) #\P (> a)) left)
3546        (pattern-match-and-bind '((> k) #\P) left)
3547        (pattern-match-and-bind '((> a)) left))
3548    (or (pattern-match-and-bind '((> w) (> d)) right)
3549        (pattern-match-and-bind '((> w) (> d) #\E (> e)) right))
3550    (when *scale-factor*
3551      (setf k *scale-factor*))
3552    (let ((directive
3553           (list (concatenate 'string
3554                              "~" (fixnum-string w) ","
3555                              (fixnum-string d) ","
3556                              (fixnum-string e) ","
3557                              (fixnum-string k) ",'*,,'D"
3558                              (if *SP* "@E" "E")))))
3559      (list a (list directive)))))
3560
3561(defun parse-format-descriptor-G (left right)
3562  (let ((k 0) (a 1) w d (e 2))
3563    (declare (special k a w d e *scale-factor*))
3564    (or (pattern-match-and-bind '((> k) #\P (> a)) left)
3565        (pattern-match-and-bind '((> k) #\P) left)
3566        (pattern-match-and-bind '((> a)) left))
3567    (or (pattern-match-and-bind '((> w) (> d)) right)
3568        (pattern-match-and-bind '((> w) (> d) #\E (> e)) right))
3569    (when *scale-factor*
3570      (setf k *scale-factor*))
3571    (let ((directive
3572           (list (concatenate 'string
3573                              "~" (fixnum-string w) ","
3574                              (fixnum-string d) ","
3575                              (fixnum-string e) ","
3576                              (fixnum-string k) ",'*,,'E"
3577                              (if *SP* "@G" "G")))))
3578      (list a (list directive)))))
3579
3580(defun parse-format-descriptor-/ ()
3581   '("~%"))
3582
3583(defun parse-format-descriptor-TR (s)
3584   (list (concatenate 'string "~" (fixnum-string s) "@T")))
3585
3586
3587(defun parse-format-descriptor-X (w)
3588   (list (concatenate 'string "~" (fixnum-string w) "@T")))
3589
3590(defun parse-format-descriptor-P (w)
3591  (declare (special *scale-factor*))
3592  ;; Save the scale-factor away so we can use it later.
3593  (setf *scale-factor* (fixnum-string w))
3594  nil)
3595
3596(defun parse-format-descriptor-S (right)
3597   (setq *SP* (if (eq right #\P) t nil))
3598   "")
3599
3600(defun parse-format-descriptor-H (width string)
3601  (declare (ignore width))
3602  (list (coerce (mapcar #'(lambda (char-or-digit)
3603                            (cond ((numberp char-or-digit)
3604                                   (aref (princ-to-string char-or-digit) 0))
3605                                  ((symbolp char-or-digit)
3606                                   (aref (symbol-name char-or-digit) 0))
3607                                  (t
3608                                   char-or-digit)))
3609                        string)
3610                'string)))
3611
3612(defun parse-default-format-descriptor (x)
3613   (list (do ((i 1 (1+ i))
3614              (ret nil (append ret '("~A"))))
3615             ((> i (car x)) ret))))
3616
3617;; given a list containing /'s put commas on either side
3618;; e.g. (x / y) -> ( |,| / |,| y)
3619;;      (/ x) -> (/ |,| x)
3620;;
3621;; Note that f2cl will convert // to f2cl-//, so if we find that, we
3622;; need to insert the appropriate number of commas and slashes.
3623(defun fix-slashes (x)
3624  (do ((lis x (cdr lis))
3625       (ret nil
3626            (append ret (cond ((eq (car lis) 'f2cl-//)
3627                               (cond ((and ret (cdr lis))
3628                                      '(|,| / |,| / |,|))
3629                                     ((cdr lis)
3630                                      '(/ |,| / |,|))
3631                                     (t
3632                                      '(|,| / |,| /))))
3633                              ((eq (car lis) '/)
3634                               (cond ((and ret (cdr lis))
3635                                      '(|,| / |,|))
3636                                     ((cdr lis)
3637                                      '(/ |,|))
3638                                     (t '(|,| /))))
3639                              (t
3640                               (list (car lis)))))))
3641      ((null lis) ret)))
3642
3643
3644;; Creates the slots for the common block.  Each variable in the
3645;; common block is a slot.  We initialize the slot with the
3646;; appropriate value and type.  Even if the array dimensions are
3647;; known, we don't use them here, just in case the dimensions contain
3648;; Fortran PARAMETER values.
3649(defun make-common-block-vars (varlist common_var_decls)
3650  ;; VARLIST is the list of variables in the common block.
3651  ;; COMMON_VAR_DECLS is a set of declaims computed in
3652  ;; INSERT-DECLARATIONS.  We use that to determine the appropriate
3653  ;; initalizations for the variables.
3654  (if *common-blocks-as-arrays*
3655      (make-common-block-vars-as-array varlist common_var_decls)
3656      (mapcar #'(lambda (var)
3657                  #+nil
3658                  (progn
3659                    (format t "var = ~A~%" var)
3660                    (format t "decl = ~A~%" (find var (rest common_var_decls)
3661                                                  :key #'third)))
3662                  (let* ((decl (find var (rest common_var_decls)
3663                                     :key #'third))
3664                         (var-type (if decl (second decl) nil))
3665                         (dims (cond ((and (listp var-type)
3666                                           (subtypep var-type 'array))
3667                                      (cond
3668                                        ((subtypep var-type 'string)
3669                                         (third var-type))
3670                                        (t
3671                                         ;;(format t "array var-type = ~A ~A~%" var var-type)
3672                                         ;;(format t "lookup-array-bounds ~A = ~A~%" var (lookup-array-bounds var))
3673
3674                                         ;; If the dimension of the array is
3675                                         ;; a number, use the actual
3676                                         ;; dimension.  Otherwise use 0.
3677                                         (if (every #'numberp (third var-type))
3678                                             (third var-type)
3679                                             0))))
3680                                     (t nil)))
3681                         (var-init
3682                          (cond ((and (listp var-type)
3683                                      (subtypep (first var-type) 'array))
3684                                 `(make-array ',dims :element-type ',(second var-type)
3685                                              :initial-element
3686                                              ,(cond
3687                                                ((subtypep (second var-type) 'logical)
3688                                                 nil)
3689                                                ((subtypep (second var-type) 'character)
3690                                                 #\space)
3691                                                (t
3692                                                 (coerce 0 (second var-type))))))
3693                                ((subtypep var-type 'logical)
3694                                 nil)
3695                                (t
3696                                 (coerce 0 var-type)))))
3697                    ;; Initialize the slot with a 0 of the appropriate
3698                    ;; type (for scalars) or a zero element array of the
3699                    ;; appropriate dimensions for array slots.
3700                    #+nil
3701                    (when dims
3702                      (format t "dims = ~A~%" dims)
3703                      (format t "new dims = ~A~%" (subst '(*) 0 dims))
3704                      (format t "relaxed  = ~A~%" (make-list (length dims) :initial-element '*)))
3705                    (if dims
3706                        `(,var ,var-init
3707                               :type (,*array-type* ,(second var-type)
3708                                                    ,(if *relaxed-array-decls*
3709                                                         (make-list (if (listp dims)
3710                                                                        (length dims)
3711                                                                        1)
3712                                                                    :initial-element '*)
3713                                                         (subst '(*) 0 dims))))
3714                        `(,var ,var-init :type ,var-type))))
3715              varlist)))
3716
3717(defun make-common-block-vars-as-array (varlist common_var_decls)
3718  (let ((part 0)
3719        (prev-type nil)
3720        (total-len 0)
3721        (slots nil))
3722    (dolist (v varlist)
3723      (let* ((decl (find v (rest common_var_decls) :key #'third))
3724             (var-type (if decl (second decl) nil))
3725             (el-type (if (subtypep var-type 'array)
3726                          (second var-type)
3727                          var-type))
3728             #+nil
3729             (dims (cond ((and (listp var-type)
3730                               (subtypep var-type 'array)
3731                               (not (subtypep var-type 'string)))
3732                          ;;(format t "array var-type = ~A ~A~%" v var-type)
3733                          ;;(format t "lookup-array-bounds ~A = ~A~%" v (lookup-array-bounds v))
3734
3735                          ;; If the dimension of the array is
3736                          ;; a number, use the actual
3737                          ;; dimension.  Otherwise use 0.
3738                          (if (every #'numberp (third var-type))
3739                              (third var-type)
3740                              0))
3741                         (t nil))))
3742        (unless prev-type
3743          (setf prev-type el-type))
3744        (let ((len (if (subtypep var-type 'array)
3745                              (first (third var-type))
3746                              1)))
3747          (cond ((and (subtypep prev-type el-type)
3748                      (subtypep el-type prev-type))
3749                 ;; Keep accumulating
3750                 (incf total-len len))
3751                (t
3752                 ;; Different type.  Stop accumulating
3753                 ;;(format t "Part ~A:  Len ~A, type ~A ~%" part total-len prev-type)
3754                 (push `(,(intern (format nil "PART-~D" part))
3755                          (make-array ,total-len :element-type ',prev-type)
3756                          :type (simple-array ,prev-type (,total-len)))
3757                       slots)
3758                 (setf prev-type el-type)
3759                 (incf part)
3760                 (setf total-len len))))
3761        ;;(format t "var = ~A :type ~A :el-type ~A :dims ~A~%" v var-type el-type dims)
3762        ))
3763    (when prev-type
3764      ;;(format t "Part ~A:  Len ~A, type ~A~%" part total-len prev-type)
3765      (push `(,(intern (format nil "PART-~D" part))
3766              (make-array ,total-len :element-type ',prev-type)
3767              :type (simple-array ,prev-type (,total-len)))
3768            slots))
3769    (nreverse slots)))
3770                             
3771;; Create a structure for the given common blocks.
3772(defun make-common-block-structure (common_var_decls)
3773  (let ((res '()))
3774    (maphash #'(lambda (key varlist)
3775                 ;;(format t "key varlist = ~S ~S~%" key varlist)
3776                 ;;(format t "res = ~S~%" res)
3777                 ;; The varlist looks something like (v1 v2 v3
3778                 ;; (v3-dims) v4 (v4-dims)).  That is if the variable
3779                 ;; is an array, the following tiem in varlist gives
3780                 ;; the dimensions of the array.
3781                 (push `(defstruct (,key (:predicate ,(intern (concatenate 'string
3782                                                                           (symbol-name '#:is-)
3783                                                                           (symbol-name key)
3784                                                                           (symbol-name '#:-p)))))
3785                         ,@(make-common-block-vars varlist common_var_decls))
3786                       res))
3787             *common-blocks*)
3788    (nreverse res)))
3789
3790(defun make-common-block-var-init (varlist common_var_decls)
3791  (flet ((fixup-bounds (bounds)
3792           (mapcar #'(lambda (bound)
3793                       (if (every #'numberp bound)
3794                           (1+ (- (second bound) (first bound)))
3795                           `(1+ (- ,(second bound) ,(first bound)))))
3796                   bounds)))
3797    (let ((initializer '()))
3798      (dolist (var varlist)
3799        (let* ((decl (find var (rest common_var_decls)
3800                           :key #'third))
3801               (var-type (if decl (second decl) nil))
3802               (dims (cond ((and (listp var-type)
3803                                 (subtypep (first var-type) 'array)
3804                                 (not (subtypep var-type 'string)))
3805                            (fixup-bounds (lookup-array-bounds var)))
3806                           (t nil)))
3807               (var-init (cond ((and (listp var-type)
3808                                     (subtypep (first var-type) 'array))
3809                                ;; If the dimensions are numbers,
3810                                ;; we've already initialized the array
3811                                ;; in the structure definition.
3812                                (unless (every #'numberp dims)
3813                                  `(make-array (* ,@dims)
3814                                               :element-type ',(second var-type)
3815                                               :initial-element ,(cond ((subtypep (second var-type) 'logical)
3816                                                                        nil)
3817                                                                       (t
3818                                                                        (coerce 0 (second var-type)))))))
3819                               ((subtypep var-type 'logical)
3820                                nil)
3821                               (t
3822                                (coerce 0 var-type)))))
3823          #+nil
3824          (progn
3825            (format t "dims = ~A~%" dims)
3826            (format t "var-init = ~A~%" var-init))
3827          (when (and dims var-init)
3828            (setf initializer (append initializer
3829                                      `(,(intern (symbol-name var) :keyword) ,var-init))))))
3830      initializer)))
3831
3832;; This assigns the common block structure to a global variable.  The
3833;; common block is initialized with reasonable defaults.  The
3834;; KEY-PARAMS is needed, just in case arrays in the common block are
3835;; dimensioned from PARAMETER values.
3836(defun make-common-block-init (comm-blocks comm-decls key-params)
3837  ;; COMM-BLOCKS is the hash table of all common blocks.  COMM-DECLS
3838  ;; is the list of declaims for the variables in the common block.
3839  ;; KEY-PARAMS is the list of Fortran PARAMETER values.
3840  ;; KEY-PARAM-DECLS is the appropriate set of declarations for the
3841  ;; PARAMTERs.
3842  (let ((var-inits '()))
3843    (maphash
3844     #'(lambda (key val)
3845         (let* ((init (make-common-block-var-init val comm-decls))
3846                (new-keys (remove-unused-key-params key-params init))
3847                (new-decls (make-key-param-decls new-keys)))
3848           (push `(defparameter ,(intern (concatenate 'string
3849                                                      "*"
3850                                                      (symbol-name key)
3851                                                      (symbol-name '#:-common-block*)))
3852                   (let* ,new-keys
3853                     ,@new-decls
3854                     (,(intern (concatenate 'string
3855                                            (symbol-name '#:make-)
3856                                            (symbol-name key)))
3857                       ,@init)))
3858                 var-inits)))
3859     comm-blocks)
3860    (nreverse var-inits)))
3861;;;-----------------------------------------------------------------------------
3862;;; end of f2cl5.l
3863;;;
3864;;; $Id$
3865;;; $Log$
3866;;; Revision 1.204  2010/02/23 05:21:30  rtoy
3867;;; Fix declaration for default integer type.  Previously the type was
3868;;; INTEGER but it should have been INTEGER4.
3869;;;
3870;;; Revision 1.203  2010/02/23 03:37:24  rtoy
3871;;; Add :PROMOTE-TO-DOUBLE option to promote all single precision
3872;;; variables and constants to double precision.
3873;;;
3874;;; NOTES:
3875;;; o Update
3876;;;
3877;;; f2cl1.l:
3878;;; o Add :PROMOTE-TO-DOUBLE keyword to F2CL and F2CL-COMPILE.
3879;;; o Add MAYBE-PROMOTE-TYPE to promote the specified type if specified.
3880;;;
3881;;; f2cl5.l:
3882;;; o Update declarations and initializers to promote the declaration and
3883;;;   initial value if needed.
3884;;;
3885;;; Revision 1.202  2010/02/23 00:59:12  rtoy
3886;;; Support the Fortran capability of passing an array of one type
3887;;; to a routine expecting a different type.  Currently only supports REAL
3888;;; and COMPLEX arrays (and their double precison versions).
3889;;;
3890;;; NOTES:
3891;;; o Update
3892;;;
3893;;; f2cl0.l:
3894;;; o Export new symbols f2cl-copy-seq and make-compatible-seq.
3895;;;
3896;;; f2cl1.l:
3897;;; o New variable *copy-array-parameter* for keeping track of the option
3898;;;   for f2cl and f2cl-compile.
3899;;; o Update f2cl and f2cl-compile to recognize :copy-array-parameter.
3900;;; o Modify massage-arglist and generate-call-to-routine to handle the
3901;;;   new :copy-array-parameter capability.
3902;;;
3903;;; f2cl5.l:
3904;;; o Fix issue where quoted elements were modified.  They shouldn't be.
3905;;; o Fix issue where (array simple-float (*)) would get erroneously
3906;;;   converted to (array simple-float (f2cl-lib:int-mul)).  We want to
3907;;;   leave bare * alone.
3908;;;
3909;;; macros.l:
3910;;; o New macro f2cl-copy-seq to generate code to copy a sequence
3911;;;   appropriately.
3912;;; o New function to create a compatible array to support
3913;;;   :copy-array-parameter.
3914;;;
3915;;; Revision 1.201  2009/12/14 22:36:46  rtoy
3916;;; GENERATE-WITH-ARRAY in INSERT-DECLARATIONS was figuring out the type
3917;;; of strings incorrectly.
3918;;;
3919;;; Revision 1.200  2009/01/19 02:38:17  rtoy
3920;;; The number of repetitions for the D format descriptor should default
3921;;; to 1, not NIL, like we do for E, F, and G.
3922;;;
3923;;; Revision 1.199  2009/01/07 19:16:59  rtoy
3924;;; Minor change on how common blocks are initialized.  We want to make
3925;;; the DEFPARAMETER a top-level form so the compile-time side-effects
3926;;; happen.
3927;;;
3928;;; Revision 1.198  2009/01/03 00:51:28  rtoy
3929;;; o ENTRY-FUNCTIONS was leaving junk in the first part of the function.
3930;;;   The parent subprogram name was left as the first statement of the
3931;;;   function.  This causes compilation errors since it's usually an
3932;;;   undefined variable.
3933;;;
3934;;; o PARSE-IMPLIED-DO did not call ID-EXPRESSION on the optional step
3935;;;   argument for the implied-do loop.
3936;;;
3937;;; Revision 1.197  2008/09/11 15:03:25  rtoy
3938;;; o Need a few more special cases where we don't want to mangle the
3939;;;   symbol name.
3940;;; o Add some comments on why we append.
3941;;;
3942;;; Revision 1.196  2008/09/10 18:09:43  rtoy
3943;;; Don't think sign should be an +allowed-lisp-name+.
3944;;;
3945;;; Revision 1.195  2008/09/10 17:56:24  rtoy
3946;;; Append a $ for external symbols in the f2cl-lib package.  Not strictly
3947;;; necessary, but makes the code look nicer.  So if the fortran code used
3948;;; the variable flog, we don't see the translation using f2cl-lib:flog,
3949;;; but flog$.
3950;;;
3951;;; Revision 1.194  2008/09/10 17:42:01  rtoy
3952;;; Fixes for check_new_vbles.
3953;;;
3954;;; o flog, fsqrt, ffloat, freal, expt are valid Fortran variable names so
3955;;;   we need to allow them.  (Previously, they wouldn't get initialized
3956;;;   and cause compilation errors.  These variables are in the f2cl-lib
3957;;;   package instead of the current package, which is annoying.)
3958;;; o For function calls, we only need to look at the args for new
3959;;;   variables; the function itself isn't a new variable.
3960;;;
3961;;; Revision 1.193  2008/09/09 18:56:41  rtoy
3962;;; Forgot to include /= in check_new_vbles.  /= can't be a Fortran
3963;;; variable name.
3964;;;
3965;;; Revision 1.192  2008/03/14 19:59:03  rtoy
3966;;; Fix the issue with do loops with the same end statement.
3967;;;
3968;;; Not 100% sure this is correct and I still don't quite understand how
3969;;; all of this works.
3970;;;
3971;;; odepack/demo7/opkdemo7.f:
3972;;; o Revert to older code, where we use the same labels for the do loop.
3973;;;   This is a test case for the changes we're making and was how we
3974;;;   discovered the problem.
3975;;;
3976;;; f2cl5.l:
3977;;; o Fix the issue with do loops.
3978;;;
3979;;; Revision 1.191  2008/03/14 13:11:46  rtoy
3980;;; Use E as the exponent marker for Fortran G format descriptor.
3981;;;
3982;;; Revision 1.190  2008/03/11 16:54:21  rtoy
3983;;; f2cl1.l:
3984;;; o Support data statements of the form (from hs109.f):
3985;;;
3986;;;      data x /nx*0/
3987;;;
3988;;;   where nx is initialized in a PARAMETER statement.
3989;;; o Recognize and handle implied-do loops in data statements like the
3990;;;   following (from tp383mod.f):
3991;;;
3992;;;      data (a(j), a(j+1), j=1,7) /.../
3993;;;
3994;;;
3995;;; f2cl5.l:
3996;;; o Support changes in f2cl1.l to support those kinds of data implied-do
3997;;;   loops.  Basically just need to get the dimensions and types for
3998;;;   lists of variables instead of just one variable.
3999;;;
4000;;; Revision 1.189  2008/03/06 22:02:26  rtoy
4001;;; Check for new variables in READ statements.
4002;;;
4003;;; Revision 1.188  2008/03/06 18:19:24  rtoy
4004;;; When merging data and save inits, we clean up the declarations too
4005;;; because the merging may end up removing lots of variables.  (See
4006;;; donlp2/o8msg for an example.)
4007;;;
4008;;; Revision 1.187  2008/03/06 17:39:25  rtoy
4009;;; Declare Fortran PARAMETER variables as ignorable since we can't always
4010;;; tell if they're used or not.  Gets rid of some compiler warnings.
4011;;;
4012;;; Revision 1.186  2008/03/04 18:00:48  rtoy
4013;;; In block data subprograms, we were inadvertently deleting the
4014;;; initializer for strings.  Not sure if this gets all of the cases.
4015;;;
4016;;; Revision 1.185  2008/03/03 19:27:20  rtoy
4017;;; o Skip over make-array forms in CHECK_NEW_VBLES
4018;;; o SYM-IS-NUMBER-P is more careful about matching the EXPR
4019;;;   to an f2cl-hacked number.
4020;;; o Check for new variables in PARSE-WRITE and PARSE-PRINT has
4021;;;   been moved to PARSE-OUTPUT-ARGUMENT where it belongs.  We need
4022;;;   to do it there so we can properly handle implied do loops and
4023;;;   such
4024;;;
4025;;; Revision 1.184  2008/03/03 17:03:09  rtoy
4026;;; Need to check for new variables in WRITE and PRINT statements.
4027;;;
4028;;; Revision 1.183  2008/02/28 20:06:47  rtoy
4029;;; MERGE-DATA-AND-SAVE-INITS:
4030;;; o Extract the array dimensions carefully.  We can only the the
4031;;;   initializing if the array dimensions are all numbers.  (Could extend
4032;;;   to some parameter values).
4033;;; o Only do the initialization stuff if we have initial values and if
4034;;;   the dimensions are known.
4035;;;
4036;;; INSERT-DECLARATIONS:
4037;;; o Before calling MERGE-DATA-AND-SAVE-INITS, remove any SAVE'd
4038;;;   variables that are also in common blocks because in this
4039;;;   implementation, common block vars are always saved.
4040;;;
4041;;; These changes allow donlp2 to build, run, and pass many tests.
4042;;; (Didn't try them all.)
4043;;;
4044;;; Revision 1.182  2008/02/26 04:18:25  rtoy
4045;;; If an initializer for a string array is already given, don't do
4046;;; anything.  (Do we need to do the same for an number array
4047;;; initializer?)
4048;;;
4049;;; Revision 1.181  2008/02/22 22:52:33  rtoy
4050;;; Oops.  check_new_vbles was skipping over the first arg in a function
4051;;; call.
4052;;;
4053;;; Revision 1.180  2008/02/22 22:19:34  rtoy
4054;;; Use RCS Id as version.
4055;;;
4056;;; Revision 1.179  2008/02/22 22:13:18  rtoy
4057;;; o Add function F2CL-VERSION to get version info.
4058;;; o Add version string to each of the files so F2CL-VERSION can get the
4059;;;   version info.  The version string is basically the date of when the
4060;;;   file was last checked in.
4061;;;
4062;;; Revision 1.178  2008/02/22 16:03:42  rtoy
4063;;; Fix MERGE-DATA-AND-SAVE-INITS.  This was causing f2cl to miscompile
4064;;; dparck.f in TOMS 717.
4065;;;
4066;;; o Initialize the array even if we don't have enough initializers for
4067;;;   the full array.  Should be ok.  The missing elements are initialized
4068;;;   to zero (for numbers)
4069;;; o Handle string initializers too.  Missing elements are initialized to
4070;;;   a string of spaces.
4071;;;
4072;;; Revision 1.177  2007/10/02 14:44:23  rtoy
4073;;; MERGE-DATA-AND-SAVE-INITS was mishandling initializers to arrays.  If
4074;;; the initializers didn't initialize all of the elements of the arrays,
4075;;; the initializers were discarded.
4076;;;
4077;;; Revision 1.176  2007/09/29 17:04:40  rtoy
4078;;; o Revert previous change.
4079;;; o If variable is dimensioned in a common block statement, don't
4080;;;   initialize it in make-initialisation.  Also, no initialization
4081;;;   needed if the variable is in a common block.
4082;;;
4083;;; This might need more work.
4084;;;
4085;;; Revision 1.175  2007/09/29 02:25:30  rtoy
4086;;; Need to check for reserved Lisp names for the variable in the implied
4087;;; do loop.
4088;;;
4089;;; Revision 1.174  2007/09/28 05:00:58  rtoy
4090;;; To support multidimensional arrays in implied do loops better, we need
4091;;; to pass the entire array bounds, including upper and lower limits so
4092;;; that array indexing can work.
4093;;;
4094;;; f2cl5.l:
4095;;; o Find the entire array bounds.
4096;;; o Don't use make-declaration to get the array type.  Explicitly look
4097;;;   through *explicit_vble_decls* to find the type.  (Are there other
4098;;;   places we need to look?)
4099;;;
4100;;; macros.l:
4101;;; o Pass the entire list of array bounds to fref so we can handle
4102;;;   multidimensional arrays.
4103;;;
4104;;; Revision 1.173  2007/09/28 03:48:56  rtoy
4105;;; Handle implied do loops better in DATA statements.
4106;;;
4107;;; f2cl1.l:
4108;;; o Handle implied do loops where the array is multidimensional.
4109;;;
4110;;; f2cl5.l:
4111;;; o Make sure we get all the lower bounds of the array dimensions.
4112;;; o Make sure we check for reserved Lisp names when we figure out the
4113;;;   type of the array.
4114;;;
4115;;; Revision 1.172  2007/09/27 14:53:22  rtoy
4116;;; If there are no items to be printed in a WRITE or PRINT statement,
4117;;; make sure no args are given to FFORMAT.  This confuses FFORMAT.
4118;;;
4119;;; Revision 1.171  2007/09/27 02:12:12  rtoy
4120;;; Support the L edit descriptor better.
4121;;;
4122;;; f2cl5.l:
4123;;; o Recognize the L descriptor and convert it to ~wA.
4124;;;
4125;;; macros.l:
4126;;; o Convert T and NIL to :T and :F, respectively.  When coupled with ~A,
4127;;;   this prints as T and F, as desired.
4128;;;
4129;;; Revision 1.170  2007/09/26 17:57:09  rtoy
4130;;; Fix up new PARSE-IMPLIED-DO that uses push instead of append to create
4131;;; the arg list.  This version is used now and donlp2 compiles and runs
4132;;; ok (for the antenna1 test case).
4133;;;
4134;;; Revision 1.169  2007/09/26 16:58:48  rtoy
4135;;; Was not correctly handling parameter keywords in block data
4136;;; subprograms.
4137;;;
4138;;; Revision 1.168  2007/09/26 16:32:45  rtoy
4139;;; Remove debugging prints.
4140;;;
4141;;; Revision 1.167  2007/09/26 16:31:06  rtoy
4142;;; o Revert to old version of PARSE-IMPLIED-DO.  The new version doesn't
4143;;;   work in some situations.
4144;;; o Add function MAKE-KEY-PARAM-DECLS to create the appropriate
4145;;;   declarations for parameter keyword args.  Use it in the appropriate
4146;;;   places.
4147;;; o Preserve value key-params.  Use new code-key-params that has unused
4148;;;   values removed for use with code.
4149;;; o Add support for removing unused parameter keywords in initializing
4150;;;   common blocks.  This reduces the number of Lis pcompiler warnings
4151;;;   quite a bit.
4152;;;
4153;;; Revision 1.166  2007/09/26 15:21:45  rtoy
4154;;; o Use push instead of append in creating the lists for implied-do
4155;;;   loops.
4156;;; o Don't use RET for the implied-do loops.  Use %RET instead, since
4157;;;   %RET can't be a Fortran variable.
4158;;;
4159;;; Revision 1.165  2007/09/26 15:10:22  rtoy
4160;;; o Grovel over the Fortran PARAMETER list and remove any that are not
4161;;;   used by other PARAMETER items or by the code.
4162;;; o Grovel over the symbol macros used to access common blocks and
4163;;;   remove the ones that are not used in the code.
4164;;;
4165;;; Revision 1.164  2007/09/26 13:10:15  rtoy
4166;;; Better list-directed output.
4167;;;
4168;;; f2cl5.l:
4169;;; o For list-directed output (format is *), return :list-directed to
4170;;;   tell format that we're using list-directed output.  (The previous
4171;;;   scheme didn't really work well.)
4172;;;
4173;;; macros.l:
4174;;; o Add FLATTEN-LIST function
4175;;; o Don't output a newline for repeated items.  We shouldn't do that.
4176;;; o Add support for :list-directed output.  We recognize that and then
4177;;;   just output all the args in a special way.
4178;;;
4179;;; Revision 1.163  2007/09/25 21:58:42  rtoy
4180;;; Revert previous change.
4181;;;
4182;;; Revision 1.162  2007/09/25 21:31:32  rtoy
4183;;; f2cl5.l:
4184;;; o Slight change in the format used for "*" format.
4185;;; o Change the repeatable descriptors to remove the repeat count if the
4186;;;   count is 1.  This was confusing the execute-format when determining
4187;;;   when to print out newlines.  This change applied to I, F, E, D, and
4188;;;   G descriptors.
4189;;;
4190;;; macros.l:
4191;;; o Handle printing of "repeat forever" loops better.  An extra arg to
4192;;;   EXECUTE-FORMAT tells us to repeat "forever".
4193;;; o Output a newline at the end of a repeated specification.
4194;;;
4195;;; Revision 1.161  2007/09/25 18:48:13  rtoy
4196;;; f2cl1.l:
4197;;; o Comment out the ill-designed ID-WRITE-FORMAT stuff.  This is now
4198;;;   handled in a much better way when parsing WRITE statements.
4199;;;
4200;;; f2cl5.l:
4201;;; o Handle FMT=<string> cases in WRITE statements here.  We just go get
4202;;;   the string, parse it as a format statement and return the result.
4203;;;
4204;;; Revision 1.160  2007/09/25 17:31:05  rtoy
4205;;; f2cl5.l:
4206;;; o Return #\: when encountering a colon edit descriptor.
4207;;;
4208;;; macros.l:
4209;;; o Recognize #\: and terminate processing if there are no arguments
4210;;;   left.
4211;;;
4212;;; Revision 1.159  2007/09/25 17:23:52  rtoy
4213;;; o Need to check for reserved lisp names when looking up array bounds
4214;;;   in data initializers.
4215;;; o Recognize colon format descriptors.  Currently, just return the
4216;;;   empty string, but it's supposed to terminate format control.
4217;;;
4218;;; Revision 1.158  2007/09/24 20:07:15  rtoy
4219;;; o Extract the actual variable name in implied do loops.  (Was messing
4220;;;   this up in some data statements.)
4221;;;
4222;;; Revision 1.157  2007/09/23 20:51:43  rtoy
4223;;; Previous checkin changed how character strings are initialized.
4224;;; Modify code accordingly.  (This needs to be rethought and made less
4225;;; fragile.)
4226;;;
4227;;; Revision 1.156  2007/09/21 20:41:16  rtoy
4228;;; MAKE-CHAR-INIT was not correctly handling a scalar character variable
4229;;; with a known length.
4230;;;
4231;;; (This might need more work still.)
4232;;;
4233;;; Revision 1.155  2007/09/20 17:44:45  rtoy
4234;;; Was not constructing the initializer for strings in a common block
4235;;; correctly.  This may need some more work.
4236;;;
4237;;; Revision 1.154  2007/09/20 15:18:33  rtoy
4238;;; Was not initializing strings with the correct data.  We were trying to
4239;;; coerce 0 to a character, which doesn't work.
4240;;;
4241;;; Revision 1.153  2007/09/19 18:28:52  rtoy
4242;;; Was not correctly handling things like
4243;;;
4244;;;  (OPEN UNIT = 1, FILE = path // '.dat')
4245;;;
4246;;; because we expected the value of each option to be a single item.  We
4247;;; now parse the value to get the correct expression.
4248;;;
4249;;; Revision 1.152  2006/11/28 19:04:07  rtoy
4250;;; o fchar and cmplx shouldn't be Fortran variables.
4251;;; o Clean up some compiler warnings about unused vars and functions.
4252;;;
4253;;; Revision 1.151  2006/11/28 17:43:53  rtoy
4254;;; f2cl-// can't be a Fortran variable.
4255;;;
4256;;; Revision 1.150  2006/11/26 04:43:55  rtoy
4257;;; Replace %false% and %true% in a different way and fix a typo.
4258;;;
4259;;; Revision 1.149  2006/11/24 05:06:58  rtoy
4260;;; Logical arrays were not getting initialized from data statements.
4261;;;
4262;;; Revision 1.148  2006/05/04 19:10:11  rtoy
4263;;; We were not correctly testing for the variable types in the common
4264;;; block when we are using common-as-array feature.  This was caused by a
4265;;; previous change where our type declarations sometimes come out as
4266;;; (type (double-float) foo) instead of (type double-float foo).
4267;;;
4268;;; This fix allows odepack to compile and run again.
4269;;;
4270;;; Revision 1.147  2006/05/03 20:06:42  rtoy
4271;;; Was not correctly handling handling the dimensions for a logical
4272;;; array when computing the declaration for the array.
4273;;;
4274;;; Revision 1.146  2006/05/03 17:37:23  rtoy
4275;;; o A better implementation, I think, of the separate nP edit
4276;;;   descriptor.
4277;;; o Forgot to declare *scale-factor* as special in the F, D, and G
4278;;;   descriptor parser functions.
4279;;;
4280;;; Revision 1.145  2006/05/03 17:22:46  rtoy
4281;;; src/f2cl5.l
4282;;; o We weren't handling formats like "1P,E15.8", which is the same as
4283;;;   "1PE15.8".  Make this work.  We make a note of the fact that we have
4284;;;   a nP descriptor, and the following descriptor uses it.  Afterwords,
4285;;;   the scale-factor is reset.
4286;;;
4287;;; packages/homepack/mains.f:
4288;;; o Revert the 1P change because f2cl handles this now.
4289;;;
4290;;; Revision 1.144  2006/05/03 02:31:10  rtoy
4291;;; src/f2cl1.l:
4292;;; o When parsing an entry point, keep track of the actual parent
4293;;;   function so we can generate the correct calling info.  (We only
4294;;;   support entry points with exactly the same number and type of
4295;;;   arguments so the calling info has to be the same.)
4296;;;
4297;;;   Do this by adding the parent to the list pushed on *entry-points*.
4298;;;
4299;;; o Set *subprog_name* to the function name.  (Is this right?)
4300;;;
4301;;; src/f2cl5.l:
4302;;; o If possible, use the parent name to figure out the calling info for
4303;;;   the entry point.
4304;;;
4305;;;
4306;;; With these changes hompack can be compiled twice, successfully.
4307;;; Previously polyp.f would call polynf correctly the first time, but
4308;;; when everything is recompiled, polyp.f would incorrectly call polynf
4309;;; with no args!
4310;;;
4311;;; Revision 1.143  2006/05/02 22:17:17  rtoy
4312;;; Clean declarations for parameters by combining all declarations int
4313;;; one.
4314;;;
4315;;; Revision 1.142  2006/05/02 22:12:02  rtoy
4316;;; src/f2cl5.l:
4317;;; o Try to make better declarations for variables defined in parameter
4318;;;   statements.  We'll declare them as (double-float 42d0 42d0) if the
4319;;;   parameter was initialized to 42d0.
4320;;; o MAKE-DECLARATION updated to take an extra keyword argument to
4321;;;   indicate if this is a parameter variable and to give the initial
4322;;;   value of the parameter so we can make the appropriate declaration.
4323;;; o When initializing simple variables in data statements, try to bind
4324;;;   the variable with the initial value instead binding a default 0 zero
4325;;;   and setq'ing it later.
4326;;;
4327;;; src/macros.l:
4328;;; o Change DEFTYPE for INTEGER4 to allow parameters so we can specify
4329;;;   tight bounds if desired.
4330;;;
4331;;; Revision 1.141  2006/05/01 17:38:27  rtoy
4332;;; Replace some uses of FSET with plain ol' SETF because SETF does
4333;;; everything we want it to do.  But leave some FSET's around because we
4334;;; need them later to generate initializers for DATA statements, and
4335;;; such.
4336;;;
4337;;; Revision 1.140  2006/04/28 13:28:39  rtoy
4338;;; Add type-derivation for ABS.  Otherwise, we end up with COERCE calls
4339;;; wherever ABS is used.
4340;;;
4341;;; Revision 1.139  2006/04/28 01:36:13  rtoy
4342;;; If there are no array data forms, don't emit a WITH-MULTI-ARRAY-DATA
4343;;; form either.
4344;;;
4345;;; Revision 1.138  2006/04/27 17:44:01  rtoy
4346;;; src/f2cl0.l:
4347;;; o Export dimag, dcmplx, zsqrt
4348;;;
4349;;; src/f2cl1.l:
4350;;; o Add dcmplx, dimag, and zsqrt to the list of intrinsic function
4351;;;   names.
4352;;; o When parsing "implicit none" statements, we don't modify
4353;;;   *IMPLICIT_VBLE_DECLS*. I don't think it's needed and it can cause
4354;;;   errors later on because :none is not a Lisp type.
4355;;;
4356;;; src/f2cl5.l:
4357;;; o Tell GET-FUN-ARG-TYPE about the result type of dcmplx, dsqrt, the
4358;;;   complex*8 and complex*16 special functions.
4359;;; o ABS is an allowed lisp name.  This gets rid of the spurious ABS$
4360;;;   local variable whenever we use the ABS function.
4361;;;
4362;;; src/macros.l:
4363;;; o Add implementations of dcmplx, dimag, and zsqrt.  (We need to add
4364;;;   more, I think.)
4365;;;
4366;;; Revision 1.137  2006/01/31 15:09:25  rtoy
4367;;; Try to return a 1-D array declaration when possible.
4368;;;
4369;;; Revision 1.136  2006/01/30 21:21:25  rtoy
4370;;; o Fix bug in MERGE-DATA-AND-SAVE-INITS.  For multidimensional arrays
4371;;;   that were fully initialized with data statements, f2cl was
4372;;;   forgetting to leave the fsets around to initialize them, and thus,
4373;;;   the arrays were never actually initialized.
4374;;; o Extend MERGE-DATA-AND-SAVE-INITS to support multidimensional arrays
4375;;;   that are fully initialized.
4376;;;
4377;;; Revision 1.135  2006/01/12 17:19:03  rtoy
4378;;; F2CL can handle equivalences of 2 simple variables of the same type.
4379;;;
4380;;; Revision 1.134  2006/01/11 22:57:58  rtoy
4381;;; Add rudimentary support for opening files and reading from files.
4382;;;
4383;;; src/f2cl1.l:
4384;;; o Recognize and handle open, rewind, and close statements.
4385;;;
4386;;; src/f2cl5.l:
4387;;; o Update parser for read to handle unit numbers.  Rudimentary support
4388;;;   for implied-do lists too.
4389;;; o Add parser for open, rewind, and close statements.
4390;;;
4391;;; src/macros.l:
4392;;; o Add functions and macros to handle opening, rewinding,
4393;;;   and closing files.  Needs more work still.
4394;;;
4395;;; Revision 1.133  2006/01/11 16:30:00  rtoy
4396;;; Allow implied-do loops in read statements.  Still has the f2cl
4397;;; limitations with read, but at least they're parsed and converted into
4398;;; a loop that reads into the variables.
4399;;;
4400;;; Revision 1.132  2006/01/09 00:37:43  rtoy
4401;;; src/f2cl5.l:
4402;;; o When looking for initializers, don't just remove initializers when
4403;;;   the array is not a 1-D array.  Keep them, and return a second value
4404;;;   indicating if the array is 1-D or not.
4405;;; o MAKE-CHAR-DECL was not properly declaring and initializing 2-D
4406;;;   arrays as 1-D arrays like we're supposed to.  Compute the total size
4407;;;   of the array if we can.
4408;;;
4409;;; src/macros.l:
4410;;; o F2CL-INIT-STRING needs to make a 1-D array, even if the string array
4411;;;   is multi-dimensional.
4412;;;
4413;;; Revision 1.131  2006/01/04 17:53:40  rtoy
4414;;; We were not correctly processing intialization of string arrays in
4415;;; data statements.
4416;;;
4417;;; src/f2cl1.l:
4418;;; o In PARSE-DATA1, return the entire list of initializers instead of
4419;;;   just the first, in case we have an array of initializers.
4420;;;
4421;;; src/f2cl5.l:
4422;;; o In MERGE-DATA-AND-SAVE-INITS, we need to recognize the
4423;;;   initialization of strings and such.  We don't do anything special
4424;;;   right now, like we do for arrays of numbers.
4425;;; o In INSERT-DECLARATIONS, we need to handle the case of REPLACE in the
4426;;;   *data-init*'s.  We assume it's been handled somewhere else, so
4427;;;   there's nothing to do here.
4428;;;
4429;;; Revision 1.130  2005/07/26 12:45:53  rtoy
4430;;; Oops.  Need to make the declaration anyway because we need to figure
4431;;; out the type of the variable.
4432;;;
4433;;; Revision 1.129  2005/07/17 02:17:42  rtoy
4434;;; Don't try to declare a function if the function was a parameter.  We don't really know anything about the function.
4435;;;
4436;;; Revision 1.128  2005/07/16 22:43:48  rtoy
4437;;; Make sure entry points are also entered into the function database.
4438;;;
4439;;; Revision 1.127  2005/07/16 21:00:19  rtoy
4440;;; In CHECK_NEW_VBLES, we need to add a special case for an expression
4441;;; containing ARRAY-SLICE because we don't want to add ARRAY-SLICE and
4442;;; the array type as new variables.  Are there other special cases?
4443;;;
4444;;; Revision 1.126  2005/07/14 21:38:58  rtoy
4445;;; o Change default array-type in F2CL to be the same as F2CL-COMPILE.
4446;;;
4447;;; o Add support for some EQUIVALENCE statements.  We can handle
4448;;;   equivalence statements that equivalence an array (element) to a
4449;;;   simple variable of the same type.  Everything else will cause an
4450;;;   error.  This is much better than putting a silly "not-translated"
4451;;;   string into the generated lisp file.
4452;;;
4453;;; Revision 1.125  2005/06/20 01:53:39  rtoy
4454;;; Add code to try to merge the data statement initializers into the
4455;;; declaration of the saved variable itself instead of generating a bunch
4456;;; of fset forms.
4457;;;
4458;;; See NOTES for more detail.
4459;;;
4460;;; src/NOTES:
4461;;; o Describe change
4462;;;
4463;;; src/f2cl5.l:
4464;;; o (Gross) Implementation
4465;;;
4466;;; src/f2cl1.l:
4467;;; o Update version.
4468;;;
4469;;; Revision 1.124  2005/05/26 19:18:00  rtoy
4470;;; Oops.  Remove some extraneous debugging outputs.
4471;;;
4472;;; Revision 1.123  2005/05/26 16:00:40  rtoy
4473;;; Don't create a declaration for a subprogram parameter if that
4474;;; parameter is also used as a function.  This happens if the function
4475;;; isn't declared external.
4476;;;
4477;;; Revision 1.122  2005/03/28 20:38:02  rtoy
4478;;; Make strings with an element-type of character instead of base-char,
4479;;; in case the Lisp implementation has unicode support.
4480;;;
4481;;; Revision 1.121  2004/08/15 11:16:14  rtoy
4482;;; Don't want that eval-when there.
4483;;;
4484;;; Revision 1.120  2004/08/14 19:27:41  rtoy
4485;;; Try to clean up code a little.
4486;;;
4487;;; Revision 1.119  2004/08/14 16:10:10  rtoy
4488;;; Forgot to create the symbol-macrolet for arrays in the common block,
4489;;; when using common-blocks-as-arrays.
4490;;;
4491;;; Revision 1.118  2004/08/14 04:15:56  rtoy
4492;;; o GET_ARRAY_TYPE was not computing the array type in some situations.
4493;;;   (I hope this is the right fix.)
4494;;; o Was not counting the array lengths correctly.
4495;;;
4496;;; Revision 1.117  2004/08/13 21:16:28  rtoy
4497;;; First pass at creating common blocks as arrays.  Intent is to allow
4498;;; odepack to be converted via f2cl.
4499;;;
4500;;; So a common block structure is created that creates as large an array
4501;;; as possible for consecutive elements of the same type in the common
4502;;; block.  A new array is created for each such section.  Then the
4503;;; elements of the common block are accessed either as either an
4504;;; individual element of the array or as a displaced array.
4505;;;
4506;;; This might have speed impacts, so the default is not to do this.  Use
4507;;; the keyword :common-as-array to control this feature.  Default is off,
4508;;; preserving old behavior.
4509;;;
4510;;; Revision 1.116  2003/11/15 14:16:45  rtoy
4511;;; When parsing READ, if the variable has type STRING, we need to use
4512;;; f2cl-set-string to make sure strings get the right length.
4513;;;
4514;;; Revision 1.115  2003/11/15 05:02:07  rtoy
4515;;; Some simple fixups for READ when reading into arrays.  We need to
4516;;; identify the expression to generate the correct form for setting the
4517;;; variable to what was read.
4518;;;
4519;;; READ still needs lots of work.
4520;;;
4521;;; Revision 1.114  2003/11/14 06:32:43  rtoy
4522;;; In INSERT-DECLARATIONS, we were computing var-type-list and var-decls
4523;;; incorrectly.  The were both too short when the arglist had external
4524;;; functions.
4525;;;
4526;;; Revision 1.113  2003/11/13 21:07:38  rtoy
4527;;; o Was not correctly handling a plain SAVE statement, which means save
4528;;;   all locals.  Build up the list from the declared and undeclared
4529;;;   variables.
4530;;; o Subprograms with multiple entry points weren't returning the right
4531;;;   number of values.  Fix that.
4532;;;
4533;;; Revision 1.112  2003/11/13 05:39:09  rtoy
4534;;; Generate code to use the new macro WITH-MULTI-ARRAY-DATA.
4535;;;
4536;;; Revision 1.111  2003/11/12 05:32:49  rtoy
4537;;; The test for matching arglist for ENTRY points was wrong.  Fix it.
4538;;;
4539;;; Revision 1.110  2003/07/13 18:54:51  rtoy
4540;;; Add mod to +allowed-lisp-names+.
4541;;;
4542;;; Revision 1.109  2003/07/12 04:27:02  rtoy
4543;;; o Make +reserved-lisp-names+ be T, PI, and NIL.
4544;;; o Add +allowed-lisp-names+ to be a list of names which can be used as
4545;;;   is because the Fortran usage matches the Lisp usage.  This prevents
4546;;;   spurious variables with names like ABS$ from being created.
4547;;; o Use +allowed-lisp-names+ when checking for reserved lisp names.
4548;;;
4549;;; Revision 1.108  2003/01/08 18:41:47  rtoy
4550;;; Reference symbols in the common-lisp package with "common-lisp:",
4551;;; instead of "lisp:".
4552;;;
4553;;; Revision 1.107  2003/01/08 18:37:58  rtoy
4554;;; Checking of reserved lisp names was rather weak.  Now check to see if
4555;;; the symbol is an external symbol in the common-lisp package.  If so,
4556;;; mangle the name.  (Append with $ instead of _.  Should I really do
4557;;; that?)
4558;;;
4559;;; Revision 1.106  2002/09/13 17:50:19  rtoy
4560;;; From Douglas Crosher:
4561;;;
4562;;; o Make this work with lower-case Lisps
4563;;; o Fix a few typos
4564;;; o Make a safer fortran reader.
4565;;;
4566;;; Revision 1.105  2002/05/05 21:10:10  rtoy
4567;;; Comment out extraneous print.
4568;;;
4569;;; Revision 1.104  2002/05/04 20:33:32  rtoy
4570;;; When we construct the declarations for the formal args of the
4571;;; function, we save the arg types in away as well for later use.
4572;;;
4573;;; Revision 1.103  2002/05/03 17:43:46  rtoy
4574;;; If the array type is simple-array, don't do the with-array-data stuff
4575;;; because we don't need it.
4576;;;
4577;;; Revision 1.102  2002/04/19 18:40:26  rtoy
4578;;; o Forgot to add FREAL as one of the intrinsics functions we skip over
4579;;;   when checking for new variables.
4580;;; o GET-FUN-ARG-TYPE:  was incorrectly handling MULTIPLE-VALUE-BIND
4581;;;   forms and erroneously returning INTEGER as the type.  We really need
4582;;;   to look at the function that is being called to get the type instead
4583;;;   of just looking at MULTIPLE-VALUE-BIND as function name!
4584;;;
4585;;; Revision 1.101  2002/03/20 15:50:41  rtoy
4586;;; Fix typo in getting the argument type in optimize-integer-arithmetic.
4587;;;
4588;;; Revision 1.100  2002/03/19 23:45:47  rtoy
4589;;; When calling a function, it's sometimes (fun args) or (funcall fun
4590;;; args), so we need to check before we look up the type of the function
4591;;; call.
4592;;;
4593;;; Revision 1.99  2002/03/19 23:08:24  rtoy
4594;;; Oops.  The array type should default to whatever *array-type* is, not
4595;;; simple-array!
4596;;;
4597;;; Revision 1.98  2002/03/19 17:28:07  rtoy
4598;;; o Declare some vars as ignored when creating the entry point
4599;;;   functions.
4600;;; o Add a check to make sure the entry point functions have exactly the
4601;;;   same names for the parameters and number of parameters.  That's all
4602;;;   we support right now.
4603;;; o Remove a debugging print statement.
4604;;;
4605;;; Revision 1.97  2002/03/19 06:03:14  rtoy
4606;;; First pass at adding support for ENTRY statements (multiple entry
4607;;; points into a routine).  See NOTES for description of technique.
4608;;;
4609;;; Revision 1.96  2002/03/19 04:11:46  rtoy
4610;;; GET-UPGRADED-FUN-ARG-TYPE wasn't correctly returning the type of a
4611;;; function call.  Didn't matter before, but with the recent coercion
4612;;; changes, it does.
4613;;;
4614;;; Revision 1.95  2002/03/19 02:23:09  rtoy
4615;;; According to the rules of Fortran, the initializers in a DATA
4616;;; statement are supposed to be converted to match the type of the
4617;;; variable that is being initialized.  Make it so by passing the
4618;;; variable type to the macro DATA-IMPLIED-DO so that the conversion can
4619;;; be done.
4620;;;
4621;;; Revision 1.94  2002/03/18 23:46:48  rtoy
4622;;; Was not correctly handling implicit variable declarations.  We just
4623;;; want to compare the first character of the variable agains the given
4624;;; ranges, not the whole variable name!
4625;;;
4626;;; Revision 1.93  2002/03/18 23:34:16  rtoy
4627;;; Was not correctly handling some implied do loops containing multiple
4628;;; variables in the loop in data statements.  Fix that and clean up some
4629;;; of the processing.  (Should probably do this kind of work in the f2cl
4630;;; compiler instead of at runtime, but it's only done once at runtime, so
4631;;; it's not a big deal.)
4632;;;
4633;;; Revision 1.92  2002/03/16 14:27:34  rtoy
4634;;; Remove some print statements that were left in.
4635;;;
4636;;; Revision 1.91  2002/03/15 04:04:01  rtoy
4637;;; When creating the symbol macros for accessing common block vars, we
4638;;; can get some speed gain by treating arrays specially so that we don't
4639;;; have to access the array through the structure accessor for every
4640;;; array access.  For an array, bind a new var to the array, and have the
4641;;; symbol macro reference the new var.
4642;;;
4643;;; Revision 1.90  2002/03/13 04:01:37  rtoy
4644;;; o Use INT instead of TRUNCATE when coercing parameter assignments.
4645;;; o Update OPTIMIZE-INTEGER-ARITHMETIC to handle min/max because CMUCL
4646;;;   isn't always smart enough to figure it out by itself.
4647;;; o Similarly, if we find a bare TRUNCATE, add an assertion about the
4648;;;   return value of TRUNCATE.
4649;;;
4650;;; Revision 1.89  2002/03/11 16:45:28  rtoy
4651;;; Try to optimize integer arithmetic. Fortran says integer overflow is
4652;;; undefined, so we try to wrap all integer arithmetic with (THE INTEGER4
4653;;; (op operands...)).  This can help the compiler generate better code.
4654;;;
4655;;; Revision 1.88  2002/03/10 16:19:03  rtoy
4656;;; Assignments in PARAMETER statements need to have them coerced to the
4657;;; right type.
4658;;;
4659;;; Revision 1.87  2002/03/06 23:04:10  rtoy
4660;;; Actually handle Iw.m as Fortran would.
4661;;;
4662;;; Revision 1.86  2002/03/06 03:17:52  rtoy
4663;;; With the block data name changes in f2cl1.l, we need to recognize here
4664;;; the names that are generated there in f2cl1.
4665;;;
4666;;; Revision 1.85  2002/02/17 15:58:16  rtoy
4667;;; o Implement the new array-slicing method.  (Still needs work.)
4668;;; o Try to declare all arrays as simple-array, except for arrays that
4669;;;   are parameters to a function
4670;;; o Declare some loop variables apropriately for implied do loops in
4671;;;   write statements.
4672;;; o We don't try to declare the functions used by a routine anymore.
4673;;;   (Should this be optional?)
4674;;;
4675;;; Revision 1.84  2002/02/14 14:36:16  rtoy
4676;;; Add sinh, cosh, tanh to the list of generics we need to handle.
4677;;; Expand on the comments.
4678;;;
4679;;; Revision 1.83  2002/02/09 16:08:49  rtoy
4680;;; o GET-FUN-ARG-TYPE:  We forgot to handle the AINT, SIGN, DIM, MAX, and
4681;;;   MIN intrinsics.
4682;;; o INSERT-DECLARATIONS:
4683;;;   o Rename special-proclamation to common-blocks because we don't have
4684;;;     special proclamations anymore.
4685;;;   o The declarations for common blocks are inserted only if
4686;;;     *DECLARE-COMMON-BLOCKS* is non-NIL.
4687;;; o GET-IMPLICIT-TYPE:  We don't care if the arg is a formal arg or
4688;;;   not.
4689;;; o MAKE-COMMON-BLOCK-VARS:  If *RELAXED-ARRAY-DECLS* is non-NIL, the
4690;;;   dimensions of the array in the common block is unspecified, even if
4691;;;   we already know it.  (Useful for changing the sizes of the arrays in
4692;;;   common blocks at run time.  Some Fortran code uses this feature.)
4693;;;
4694;;; Revision 1.82  2002/02/08 23:32:51  rtoy
4695;;; The last change to support block data was majorly broken.  Right idea,
4696;;; wrong implementation.  Initializers and stuff need to be inside the
4697;;; function otherwise nothing is really initialized as expected.  This
4698;;; should work better.
4699;;;
4700;;; Revision 1.81  2002/02/08 06:04:48  rtoy
4701;;; o We were generating incorrect code for symbol-macrolets for
4702;;;   initializers.  Fix it and clean it up.  Now only generate it either
4703;;;   for initialization or the body but not both since you can only
4704;;;   initialize common blocks in a block data subprogram.
4705;;; o Fix a bug wherein a variable in a parameter statement that was also
4706;;;   declared was getting the wrong type and also getting declared as a
4707;;;   local var.  Happened because we were checking the other var against
4708;;;   the wrong list (was *key-params* but should have been key-params).
4709;;;
4710;;; Revision 1.80  2002/02/08 04:27:31  rtoy
4711;;; To support BLOCK DATA subprograms, we need to have the data
4712;;; initialization part of the code wrapped by symbol-macrolets.  Make it
4713;;; so.  Move the common code to its own routine.
4714;;;
4715;;; Revision 1.79  2002/02/07 23:21:58  rtoy
4716;;; MAKE-DECLARATION
4717;;; o For some reason when we were checking for implicitly declared
4718;;;   variables, we checked to see if the variable was a formal arg or
4719;;;   not.  Formal args can be implicitly declared too, so the check is
4720;;;   removed.  (Why where we checking before?)
4721;;; o Clean up some comments.
4722;;;
4723;;; SYM-IS-NUMBER-P
4724;;; o Add some comments
4725;;; o We were incorrectly saying things like 1D%3 were not numbers, but
4726;;;   this is wrong.  It is a number.  Solves the occasional problem where
4727;;;   we got weird things like unused variables named |1D%3|.  (Off-by-one
4728;;;   bug.)
4729;;;
4730;;; Revision 1.78  2002/02/07 22:16:19  rtoy
4731;;; If an array was declared but actually dimensioned in a common block
4732;;; like
4733;;;
4734;;;     double precison c
4735;;;     common /foo/ c(42)
4736;;;
4737;;; VBLE-IS-ARRAY-P didn't think it was an array.  Fix it.
4738;;;
4739;;; Revision 1.77  2002/02/07 03:58:45  rtoy
4740;;; o The previous change messed up the parsing of the format number of a
4741;;;   write statement.  Fix it.
4742;;; o The previous change also messed up the unit number for
4743;;;   PARSE_FORMAT_DEST. Fix it.
4744;;; o Add a parser for Fortran's A format descriptor.
4745;;;
4746;;; Revision 1.76  2002/02/04 03:22:31  rtoy
4747;;; Handle the case where the unit number for a write statement can be an
4748;;; arbitrary expression.
4749;;;
4750;;; Revision 1.75  2002/01/13 16:57:52  rtoy
4751;;; When looking up variables in the declared variables list or the
4752;;; subprog arglist, we still need to handle them via Fortran's implicit
4753;;; typing rules.
4754;;;
4755;;; Revision 1.74  2002/01/09 15:31:08  rtoy
4756;;; o In GET-FUN-ARG-TYPE, we weren't correctly handling the case of unary
4757;;;   + and -.
4758;;; o When looking up the type of a variable, we need to check for the
4759;;;   variable in *subprog-arglist* as well as *declared_vbles*!
4760;;;
4761;;; Thanks to Mike Koerber for sending sample code where this fails.
4762;;;
4763;;; Revision 1.73  2002/01/08 03:24:44  rtoy
4764;;; o Correct the previous change about looking up the type of array
4765;;;   references.  If we have an fref, it can't be an array slice because
4766;;;   we would have already sliced it before we get here.
4767;;; o Try to pretty up the declarations for other functions by merging
4768;;;   them into just one declaration.
4769;;; o Group the declaration statements for variables and other functions
4770;;;   into just a single declaration.
4771;;;
4772;;; Revision 1.72  2002/01/07 20:55:40  rtoy
4773;;; In GET-FUN-ARG-TYPE, we were always returning array types for FREF.  This
4774;;; is true if array-slicing is enabled.
4775;;;
4776;;; Revision 1.71  2002/01/06 23:10:12  rtoy
4777;;; Rename *intrinsic_function_names*, *external_function_names* and
4778;;; *subprog_stmt_fns* to use dashes.
4779;;;
4780;;; Revision 1.70  2001/06/04 17:16:24  rtoy
4781;;; Print a warning if there is no implicit type given and the variable
4782;;; was not declared.  This is invalid Fortran anyway.
4783;;;
4784;;; Revision 1.69  2001/06/03 20:46:08  rtoy
4785;;; Changes to FIX-DO:
4786;;; o Add a test and code to keep FIX-DO from looping forever searching
4787;;;   for a non-existent DO label.  We cause an error now if this happens.
4788;;; o Gratuitously re-indented code.
4789;;;
4790;;; Revision 1.68  2000/09/03 02:33:39  rtoy
4791;;; FORTRAN-CONTAGION returned (complex double-float) and (complex
4792;;; single-float) which confuses f2cl.  Return complex16 and complex8
4793;;; instead, respectively.
4794;;;
4795;;; Revision 1.67  2000/08/30 16:56:24  rtoy
4796;;; In PARSE-FORMAT1, if there's no repetition factor for a group, then
4797;;; the group is supposed to be repeated forever until all the data has
4798;;; been printed.  (I think)
4799;;;
4800;;; Revision 1.66  2000/08/29 15:55:04  rtoy
4801;;; o In GET-ARG-DECL, return type INTEGER4 if the arg is a subtype of
4802;;;   INTEGER4. (So fixnum args are treated as INTEGER4 args for
4803;;;   declaration purposes instead of a union of fixnum and integer4
4804;;;   types.)
4805;;; o In PARSE-READ, don't use literal strings; make them FORTRAN_COMMENT's.
4806;;;
4807;;; Revision 1.65  2000/08/29 14:41:41  rtoy
4808;;; o Remove lots of unused code
4809;;; o Fix a typo in the Fortra D format parser: the equivalent Lisp format
4810;;;   is E not D!  Also, explicitly specify the exponent character of "D".
4811;;; o For the E format, specify an explicit exponent character of "E".
4812;;;
4813;;; Revision 1.64  2000/08/27 16:36:07  rtoy
4814;;; Clean up handling of format statements.  Should handle many more
4815;;; formats correctly now.
4816;;;
4817;;; Revision 1.63  2000/08/10 18:00:37  rtoy
4818;;; Declarations of the array type for arrays in common blocks were
4819;;; wrong.  (Oops!)
4820;;;
4821;;; Revision 1.62  2000/08/09 22:45:17  rtoy
4822;;; o In MAKE-DECLARATION, use the LOGICAL type instead of (MEMBER T NIL)
4823;;;   in declaring arrays.
4824;;; o MAKE-SPECIAL-VAR-DECL was not returning the right dimensions.
4825;;;   (After the conversion to 1-D arrays.)
4826;;; o In MAKE-COMMON-BLOCK-VARS, try to initialize arrays to the right
4827;;;   size and values.  (Particularly for logical arrays.)
4828;;; o In MAKE-COMMON-BLOCK-VAR-INIT, we didn't compute the array bounds
4829;;;   correctly.  Also, if we know the initializer for the common block
4830;;;   structure element initialized the array (because the dimension was a
4831;;;   number), don't do it when creating the structure.
4832;;;
4833;;; Revision 1.61  2000/08/07 18:55:03  rtoy
4834;;; GET-ARG-DECL was confused by arrays of strings.  We return the type
4835;;; ARRAY-STRINGS now.  (Need better names for these types or need to fix
4836;;; the code so it handles these better!)
4837;;;
4838;;; Revision 1.60  2000/08/05 19:23:16  rtoy
4839;;; Comment out some unreachable code.
4840;;;
4841;;; Revision 1.59  2000/08/04 14:20:31  rtoy
4842;;; Add very rudimentary support for Fortran READ statements.  This means
4843;;; we just basically call read and assign the result to the (simple)
4844;;; variable.  We don't even bother to look at the format number or check
4845;;; the variable type.
4846;;;
4847;;; Revision 1.58  2000/08/03 03:39:49  rtoy
4848;;; The string passed to PARSE-FORMAT-DESCRIPTOR-H can be a character,
4849;;; digit, or symbol.  These all need to be converted to character.  Make
4850;;; it so.
4851;;;
4852;;; Revision 1.57  2000/08/02 16:26:20  rtoy
4853;;; The D and E format descriptors should print out a D and E,
4854;;; respectively.  Thus add PARSE-FORMAT-DESCRIPTOR-D.
4855;;;
4856;;; Revision 1.56  2000/08/02 14:42:20  rtoy
4857;;; o Add support for parsing Hollerith strings in format statements.  Not
4858;;;   perfect because the preprocessor mangles spaces within the string,
4859;;;   but we can at least print out the non-space parts of the string.
4860;;;   Changed PARSE-FORMAT1, DESTRUCT-DESCRIPTOR-LIST, and
4861;;;   PARES-FORMAT-DESCRIPTOR-H for this.
4862;;;
4863;;; o PARSE-FORMAT-DESCRIPTOR-LIST treated D format descriptor as F
4864;;;   instead of as E.  (Should we distinguish between D and E?)
4865;;;
4866;;; o PARSE-FORMAT-DESCRIPTOR-F didn't add the fill character when the
4867;;;   number is too large to fit in the desired field.
4868;;;
4869;;; Revision 1.55  2000/07/30 05:58:48  rtoy
4870;;; Don't check for new variables inside of multiple-value-bind's that
4871;;; were created for function calls.  We only need to check in the
4872;;; arguments of the function call.
4873;;;
4874;;; Revision 1.54  2000/07/28 17:05:01  rtoy
4875;;; o We are in the f2cl package now.
4876;;; o We convert // to f2cl-//, even in format statements so fix
4877;;;   FIX-SLASHES to handle this case by replacing f2cl-// with 2 slashes,
4878;;;   as appropriate.
4879;;;
4880;;; Revision 1.53  2000/07/27 16:42:01  rtoy
4881;;; o We want to be in the CL-USER package, not the USER package.
4882;;; o Use (typep x 'integer) instead of (fixnump x) in GET-FUN-ARG-TYPE.
4883;;;
4884;;; Revision 1.52  2000/07/21 17:47:20  rtoy
4885;;; o FIXUP-EXPRESSION:  add a case to convert (- N) to just -N, when N is
4886;;;   a number.
4887;;;
4888;;; o MERGE-OPS: incorrectly merged (- (- 3) IT) to (- 3 IT).  I think
4889;;;   this is fixed now.
4890;;;
4891;;; o INSERT-DECLARATIONS: Don't fixup external function refs if an
4892;;;   intrinsic was actually a variable in the arglist.  (Missed this case
4893;;;   from before.)
4894;;;
4895;;; Revision 1.51  2000/07/20 13:43:00  rtoy
4896;;; Since all arrays are now actually stored in column-major order in a
4897;;; 1-dimensional vector, we don't need to transpose the data initializers
4898;;; anymore.  Replace fortran-transpose with fortran-data-init to
4899;;; correctly initialize the array.
4900;;;
4901;;; Revision 1.50  2000/07/19 22:17:13  rtoy
4902;;; Remove a print statement inadvertently left in.
4903;;;
4904;;; Revision 1.49  2000/07/19 14:04:28  rtoy
4905;;; o GET-FUN-ARG-TYPE returns a second value to indicate if the arg is an
4906;;;   array or not.
4907;;; o More hacking on GET-ARG-DECL.  Should now correctly identify if an
4908;;;   array is used as a parameter.  Still needs work.
4909;;; o MAKE_MAKE-ARRAY_STMT creates 1-D arrays for all arrays to support
4910;;;   Fortran array slicing.
4911;;; o In MAKE-DECLARATION, declare all arrays as 1-D even if
4912;;;   multi-dimensional, for supporting Fortran array slicing.
4913;;;
4914;;; Revision 1.48  2000/07/18 13:59:23  rtoy
4915;;; o Left out some double precision intrinsics for getting function
4916;;;   types.
4917;;; o Declarations for functions were not quite right.  Make it better, but
4918;;;   still needs some work.
4919;;; o The format of *functions-used* has changed.  Do the right thing in
4920;;;   insert-declarations.
4921;;;
4922;;; Revision 1.47  2000/07/14 21:23:37  rtoy
4923;;; o In GET-FUN-ARG-TYPE, when looking up the type of an expression,
4924;;;   handle (funcall f ...) by looking up the type of "f" instead of
4925;;;   looking up the type of "funcall"!
4926;;;
4927;;; o In FIX-DO, a goto to the end of the loop would get translated into a
4928;;;   (return).  This seems wrong, and I don't know why it wants to do
4929;;;   this.
4930;;;
4931;;; Revision 1.46  2000/07/14 15:50:25  rtoy
4932;;; o When getting the type of an arg, handle the case when the arg is
4933;;;   actually a call to make-array for array slicing.  Get the type form
4934;;;   the :element-type.
4935;;; o If the arg has type fixnum, return integer4 instead.
4936;;;
4937;;; Revision 1.45  2000/07/14 14:08:26  rtoy
4938;;; Honor the user's choice of declaring arrays as array or simple-array.
4939;;; Except we leave Fortran character strings still declared as
4940;;; simple-array.
4941;;;
4942;;; Revision 1.44  2000/07/14 13:33:26  rtoy
4943;;; Don't apply external ref fixups if the external function was also a
4944;;; parameter to the routine.  If we do, then we referring to the wrong
4945;;; thing!
4946;;;
4947;;; Revision 1.43  2000/07/13 16:55:34  rtoy
4948;;; To satisfy the Copyright statement, we have placed the RCS logs in
4949;;; each source file in f2cl.  (Hope this satisfies the copyright.)
4950;;;
4951;;;-----------------------------------------------------------------------------
Note: See TracBrowser for help on using the repository browser.