f2cl1.l 164 KB
Newer Older
rtoy's avatar
rtoy committed
1
;; -*- Mode: lisp; Package: F2CL -*-
rtoy's avatar
rtoy committed
2
3
4
5
6
7
8
9
10
11
12
 ; f2cl1.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;check
;functions:
;	f2cl
;	concaten
;	f-to-l
;---------------------------------------------------------------------------
rtoy's avatar
rtoy committed
13
(in-package :f2cl)
rtoy's avatar
rtoy committed
14
15
(defvar *verbose* nil)
(defvar *comments* nil)
16
(defparameter *f2cl-version*
17
18
19
  "Use (f2cl-version) instead")

(defparameter *f2cl1-version*
20
  "$Id: f2cl1.l,v 505dc31bee3e 2013/03/26 03:32:16 toy $")
21
22
23
24
25
26
27
28

;; Forward declarations.
(defvar *f2cl2-version*)
(defvar *f2cl3-version*)
(defvar *f2cl4-version*)
(defvar *f2cl5-version*)
(defvar *f2cl6-version*)
(defvar f2cl-lib::*f2cl-macros-version*)
29
30

(defun f2cl-version ()
31
32
33
34
35
36
37
38
39
40
  (mapcar #'(lambda (s)
	      ;; Need to strip off the leading $ so CVS/RCS won't create a new Id.
	      (string-left-trim "$Id: " s))
	  (list *f2cl1-version*
		*f2cl2-version*
		*f2cl3-version*
		*f2cl4-version*
		*f2cl5-version*
		*f2cl6-version*
		f2cl-lib::*f2cl-macros-version*)))
41

rtoy's avatar
rtoy committed
42
 
43
(defparameter *default-intrinsic-function-names*
rtoy's avatar
rtoy committed
44
  '(int ifix idint real float sngl dble cmplx dcmplx ichar char aint dint
45
46
    anint dnint nint idnint iabs abs dabs cabs mod amod dmod isign sign dsign
    idim dim ddim dprod max max0 max1 amax1 dmax1 amax0 amax1 min min0 amin1 dmin1
rtoy's avatar
rtoy committed
47
    min1 len index lge lgt lle llt aimag dimag conjg sqrt dsqrt csqrt 
48
49
    exp dexp cexp log alog dlog clog log10 alog10 dlog10 sin dsin csin
    cos dcos ccos tan dtan asin dasin acos dacos atan datan atan2 datan2
rtoy's avatar
rtoy committed
50
    sinh dsinh cosh dcosh tanh dtanh
51
52
    zsqrt
    cdabs dconjg
rtoy's avatar
rtoy committed
53
    dfloat
54
    len_trim
55
    )
56
57
58
59
60
61
62
  "A list of all the intrinsic functions in Fortran 77 (or 95)")

(defvar *intrinsic-function-names*
  nil 
  "A list of all the recognized intrinsic functions in the current
  subprogram.  This list will change if the subprogram declares a
  variable with the same name as an intrinsic.")
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77

;;------------------------------------------------------------------------------
;; Define the Fortran types that we need.  This MUST match the types
;; given in macros.l, so be sure to keep this in sync!
(deftype logical ()
  `(member t nil))

;; Decide what you want integer*4 to be.  Good choices are fixnum or
;; (signed-byte 32).  The latter is good only if your compiler does a
;; good job with this type.  If you aren't sure, use fixnum.  CMUCL
;; does a good job with (signed-byte 32).
;;
;; If you change this, you may need to change some of the macros
;; below, such as INT and AINT!

78
79
80
81
82
83
#+(or cmu scl sbcl)
(deftype integer4 (&optional (low #x-80000000) (high #x7fffffff))
  `(integer ,low ,high))
#-(or cmu scl sbcl)
(deftype integer4 (&optional low high)
  (declare (ignore low high))
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
  'fixnum)

(deftype integer2 ()
  `(signed-byte 16))
(deftype integer1 ()
  `(signed-byte 8))
(deftype real8 ()
  'double-float)
(deftype real4 ()
  'single-float)
(deftype complex8 ()
  `(complex single-float))
(deftype complex16 ()
  `(complex double-float))

(deftype array-double-float ()
    `(array double-float (*)))
(deftype array-integer4 ()
    `(array integer4 (*)))
(deftype array-single-float ()
    `(array single-float (*)))
(deftype array-strings ()
  `(array string (*)))
;;------------------------------------------------------------------------------

rtoy's avatar
rtoy committed
109
(eval-when (compile load eval)
110
  (proclaim '(special *sentable*))
111
112
  (proclaim '(special
	      *external-function-names*
rtoy's avatar
rtoy committed
113
114
115
116
117
118
	      *undeclared_vbles* *declared_vbles* *implicit_vble_decls*
	      *subprog-arglist* *data-init*
	      *explicit_vble_decls* *function-flag* *key_params*
	      *save_vbles* *program-flag* *subprog_name*
	      *subprog_common_vars*  *common_array_dims*
	      *format_stmts* *current_label*
119
	      *subprog-stmt-fns* *subprog_stmt_fns_bodies* *prune_labels*
rtoy's avatar
rtoy committed
120
121
	      *auto-save-data*
	      *functions-used*
122
	      *vble-declaration-done*
123
124
125
126
127
128
129
	      ;; Specifies how Fortran arrays should be declared (array or simple-array)
	      *array-type*
	      ;; If non-NIL, treat all array references in calls to
	      ;; routines as a slice of the array.  Thus, we create a
	      ;; displaced array.  (Implies *array-type* is array.)
	      *array-slicing*
	      ;; If non-NIL, apply array slicing (in ID-FACTOR)
rtoy's avatar
rtoy committed
130
131
132
133
134
	      *apply-array-slice*
	      ;; If non-NIL, we are parsing the LHS of an assignment.
	      ;; (Used mostly so we don't incorrectly convert the
	      ;; definition of a statement function into a call of the
	      ;; function with mutliple-value-bind.)
135
136
137
	      *parsing-lhs*
	      ;; List of statement labels in a subprogram
	      *statement-labels*
138
	      *declared-intrinsic-names*
139
	      )))
rtoy's avatar
rtoy committed
140

rtoy's avatar
rtoy committed
141
142
143
144
145
146
147
(defvar *common-blocks* (make-hash-table)
  "Hash table of all common blocks.  The key is the name of the common
block; the value is a list of all variables in the common block.")

(defvar *common-block-initialized* '())
(defvar *relaxed-array-decls* t
  "If T, array declarations with sizes are relaxed to be any size.")
rtoy's avatar
rtoy committed
148
149
150
151
152
(defvar *coerce-assignments* :never
  "This controls how assignment statements are coerced.  If T or
:always, assignments are always ccoerced.  If NIL or :never,
assignments are never coerced.  For any other value, coercion is done
only when needed. ")
rtoy's avatar
rtoy committed
153
154
(defvar *default-lisp-extension* "lisp"
  "The default extension (file type) for the output file name")
rtoy's avatar
rtoy committed
155
156
157

(defvar *fortran-extensions* '("f" "for")
  "A list of possible extensions for Fortran files.")
rtoy's avatar
rtoy committed
158
159
160
161

(defvar *declare-common-blocks* nil
  "When non-NIL, the structures for any common blocks are defined in this file")

162
163
164
(defvar *assigned-variables* nil
  "List of variables that are assigned a value")

165
166
167
(defvar *entry-points* nil
  "List of ENTRY points")

168
(defvar *f2cl-trace* nil)
169
170
171

(defvar *float-format* 'single-float)

172
173
(defvar *common-blocks-as-arrays* nil)

174
175
176
177
178
179
(defvar *common-block-file* nil)

(defvar *common-block-file-names*
  nil
  "List of files created when :common-block-file is enabled")

180
181
182
183
184
185
186
(defvar *use-function-info*
  t
  "If non-NIL, the database of function return values is used in
generating function calls and setting the argument values
correctly. If the database is incorrect, the function call will be
incorrect, so use caution.")

187
188
189
190
(defvar *equivalenced-vars* nil
  "List of equivalenced variables.  Each entry of the list is a list
  consisting of the equivalenced variables.")

191
192
193
194
195
196
197
198
199
200
201
(defvar *copy-array-parameter* nil
  "If non-NIL, array arguments are copied if the actual array element
  type is not the same type as the declared array element type.  This
  happens in some Fortran code where, say, an array of REALs is given
  to a routine expecting COMPLEXs.  When *COPY-ARRAY-PARAMETER* is
  non-NIL, F2CL will copy the actual array to a temporary array of the
  correct type, pass that to the routine and then copy the result back
  to the original array.  This is currently only implemented when
  passing a REAL/REAL*8 array to a COMPLEX/COMPLEX*16 array and
  vice-versa. ")

202
203
204
205
(defvar *promote-to-double* nil
  "If non-NIL, REAL and COMPLEX variables and arrays are promoted to
  type REAL*8 and COMPLEX*16")

206
207
208
;; For some reason Allegro needs this eval-when because it complains
;; about undefined slot accessors without this.
(eval-when (compile load eval)
209
(defstruct (f2cl-finfo (:constructor %make-f2cl-finfo))
210
  arg-types return-values calls)
211
)
212

213
214
215
(defun relax-array-decl (decls)
  (flet ((relax-1 (decl)
	   (cond ((and *relaxed-array-decls* (subtypep decl 'array))
216
		  (destructuring-bind (a &optional n l)
217
		      decl
218
		    (if (subtypep a 'string)
219
			`(,a ,@(mapcar (constantly '*) l))
220
			`(,a ,n ,(mapcar (constantly '*) l)))))
221
222
223
224
225
226
227
228
229
		 (t
		  decl))))
    (mapcar #'relax-1 decls)))

(defun make-f2cl-finfo (&key arg-types return-values calls)
  (%make-f2cl-finfo :arg-types (relax-array-decl arg-types)
		    :return-values return-values
		    :calls calls))

230
231
232
233
234
235
236
237
238
239
;; Hash table of all known converted functions.  
(defvar *f2cl-function-info*
  (let ((table (make-hash-table)))
    ;; Insert d1mach and i1mach into the table
    (setf (gethash 'd1mach table)
	  (make-f2cl-finfo :arg-types '(integer4) :return-values '(nil)))
    (setf (gethash 'i1mach table)
	  (make-f2cl-finfo :arg-types '(integer4) :return-values '(nil)))
    table))

240
241
242
;; Hash table of all statement functions
(defvar *f2cl-statement-finfo* (make-hash-table))

243
(defun clear-f2cl-finfo ()
244
245
246
247
248
249
  (clrhash *f2cl-function-info*)
  (setf (gethash 'd1mach *f2cl-function-info*)
	(make-f2cl-finfo :arg-types '(integer4) :return-values '(nil)))
  (setf (gethash 'i1mach *f2cl-function-info*)
	(make-f2cl-finfo :arg-types '(integer4) :return-values '(nil)))
  *f2cl-function-info*)
250

251
252
253
254
255
256
257
258
259
260
261
262
(defun save-f2cl-finfo (path)
  "Save *F2CL-FUNCTION-INFO* to PATH.  This file can be reloaded
later to provide the function information for f2cl to compile functions
correctly"
  (with-open-file (s path :direction :output :if-exists :supersede)
    (maphash #'(lambda (key val)
		 (write `(setf (gethash ',key f2cl::*f2cl-function-info*)
			  ,val)
			:stream s
			:pretty t)
		 (terpri s))
	     *f2cl-function-info*)))
rtoy's avatar
rtoy committed
263
;----------------------------------------------------------------------------
rtoy's avatar
rtoy committed
264

265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
(defun f2cl (input-file
	     &key
	     verbose
	     keep-temp-file
	     (extension (or *default-lisp-extension* "lisp"))

	     output-file
	     prune-labels
	     include-comments
	     (auto-save t)
	     (relaxed-array-decls t)
	     (coerce-assigns :as-needed)
	     (array-type :array array-type-p)
	     (array-slicing t)
	     (package :common-lisp-user)
	     declaim
	     declare-common
	     (float-format *read-default-float-format*)
	     common-as-array
	     common-block-file
285
	     copy-array-parameter
286
	     promote-to-double
287
	     &allow-other-keys)
rtoy's avatar
rtoy committed
288
289
  "Fortran to Common Lisp converter

290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
  INPUT-FILE               File containing Fortran code

  :OUTPUT-FILE             File to contain Lisp code

  :VERBOSE                 verbose output. Default = NIL.
  :PRUNE-LABELS            Prune unused labels. Default = NIL.
  :INCLUDE-COMMENTS        Include Fortran comments in the Lisp output (May be
			    buggy.) Default = NIL
  :AUTO-SAVE               Variables in DATA statements are automatically SAVE'd.
			   Default = T.
  :RELAXED-ARRAY-DECLS     Declarations of array sizes are relaxed in formal
			   parameters to functions. That is, any array
			   length declarations are ignored if possible,
			   like old Fortran used to. Default = T.
  :COERCE-ASSIGNS          If T or :ALWAYS, all assignment statements
			    automatically coerce the RHS to the
			    appropriate type for the assignment.  If NIL
			    or :NEVER, coercion never happens.
			    Otherwise, coercion happens as needed.  The
			    Default = :AS-NEEDED
  :EXTENSION               The extension to use for the output file, if needed.
			    Defaults to *DEFAULT-LISP-EXTENSION* or \"lisp\"
  :KEEP-TEMP-FILE          If T, the temporary file is not deleted.
			    Default = NIL.
  :ARRAY-TYPE              The type of array f2cl should use.  Should be
			    :simple-array or :array.
  :ARRAY-SLICING           When non-NIL, f2cl assumes that, whenever we do an
			    array reference in a call to a subroutine or
			    function, we are really passing a subarray
			    to the routine instead of just the single
			    value, unless f2cl knows the function takes
			    a scalar arg that is not modified.
  :PACKAGE                 A string or symbol specifying what package the
			    resulting code should be in. (Basically puts a
			    (in-package <p>) at the top.)
  :DECLAIM                 Declaim compilation options  (Basically puts a
			    (declaim <declaim>) at the top.)
  :DECLARE-COMMON          When non-NIL, any structures defintions for common
			    blocks are defined here. Otherwise, the structures
			    for the common blocks are expected to be defined
			    elsewhere.
  :FLOAT-FORMAT            Float format to use when printing the result.
			    Default is *READ-DEFAULT-FLOAT-FORMAT*
  :COMMON-AS-ARRAY         Common blocks are created as a set of arrays, and the
			    common block variables are offsets into the arrays.
			    This mimics Fortran common block layouts.
			    Default = NIL.
  :COMMON-BLOCK-FILE       If common blocks are to be declared, then
			    each common block is written to a file whose name
			    is the name of the common block, with the extension
			    \"cmn\"
  :COPY-ARRAY-PARAMETER    In some Fortran code an array of one type is passed to
			    a routine expecting a different type.  F2CL implements
			    this by creating an array and copying the data.  The
			    default is not to copy since it is relatively slow.
345
346
  :PROMOTE-TO-DOUBLE       Promote REAL and COMPLEX constants, variables, and
                            arrays to REAL*8 and COMPLEX*16 types. 
rtoy's avatar
rtoy committed
347
348
349
"


350
351
  ;;(format t "Copyright(c) 92-95 University of Waikato - all rights reserved~%")
  ;;(format t "1997, 1999 Many changes and fixes by Raymond Toy (toy@rtp.ericsson.se)~%")
rtoy's avatar
rtoy committed
352

353
354
355
  ;; Check (some) parameters for validity
  (assert (or (null coerce-assigns)
	      (member coerce-assigns '(:always :never :as-needed t))))
356
  (assert (member array-type '(:simple-array :array)))
357
  #+nil
358
359
360
  (when (and array-slicing array-type-p
	     (eq array-type :simple-array))
    (warn ":array-slicing is T, so specified :array-type of :simple-array is overridden"))
rtoy's avatar
rtoy committed
361
362
363
  (let ((*verbose* verbose)
	(*prune_labels* prune-labels)
	(*comments* include-comments)
rtoy's avatar
rtoy committed
364
365
	(*auto-save-data* auto-save)
	(*common-block-initialized* nil)
rtoy's avatar
rtoy committed
366
	(*relaxed-array-decls* relaxed-array-decls)
367
	(*coerce-assignments* coerce-assigns)
368
369
	(*array-type* (cdr (assoc array-type '((:simple-array . common-lisp:simple-array)
					       (:array . common-lisp:array)))))
370
	(*array-slicing* array-slicing)
rtoy's avatar
rtoy committed
371
	(*apply-array-slice* nil)
372
	(*declare-common-blocks* declare-common)
373
	(*assigned-variables* nil)
374
	(*entry-points* nil)
375
	(*equivalenced-vars* nil)
376
	(*float-format* float-format)
377
	(*common-blocks-as-arrays* common-as-array)
378
	(*common-block-file* common-block-file)
379
380
	(*copy-array-parameter* copy-array-parameter)
	(*promote-to-double* promote-to-double))
rtoy's avatar
rtoy committed
381

rtoy's avatar
rtoy committed
382
383
384
385
386
387
388
389
390
    (unless (probe-file input-file)
      ;; Can't find it, so look for some other possibilities
      (do* ((ext *fortran-extensions* (rest ext))
	    (path (merge-pathnames input-file (make-pathname :type (first ext)))
		  (merge-pathnames input-file (make-pathname :type (first ext)))))
	  ((or (null ext)
	       (probe-file path))
	   (setf input-file path))))
      
rtoy's avatar
rtoy committed
391
392
    (unless output-file
      (let ((input-path (pathname input-file)))
393
394
395
396
397
398
399
	(setf output-file (merge-pathnames
			   (make-pathname :host (pathname-host input-path)
					  :device (pathname-device input-path)
					  :directory (pathname-directory input-path)
					  :name (pathname-name input-path)
					  )
			   (make-pathname :type extension)))))
400
    (format t "~&;; ~S -> ~S~%" input-file output-file)
rtoy's avatar
rtoy committed
401
    (let ((processed-file (preprocess input-file)))
402
403
404
405
406
407
408
409
      (fortran-to-lisp processed-file output-file
		       :declaim declaim
		       :package package
		       :options `((:prune-labels ,prune-labels)
				  (:auto-save ,auto-save)
				  (:relaxed-array-decls ,relaxed-array-decls)
				  (:coerce-assigns ,coerce-assigns)
				  (:array-type ',array-type)
410
411
412
				  (:array-slicing ,array-slicing)
				  (:declare-common ,declare-common)
				  (:float-format ,float-format)))
rtoy's avatar
rtoy committed
413
414
415
      (unless keep-temp-file
	(delete-file processed-file))
      (values output-file))))
rtoy's avatar
rtoy committed
416

417
418
419
420
421
422
423
424
425
(defun remove-f2cl-keys (keys)
  (do ((key keys (cddr key))
       (result nil))
      ((null key)
       (nreverse result))
    (unless (member (car key)
		    '(:output-file :error-file :prune-labels :include-comments
		      :auto-save :relaxed-array-decls :coerce-assigns
		      :keep-lisp-file :array-type :array-slicing :package
426
		      :declaim :declare-common :float-format :common-as-array
427
		      :common-block-file :copy-array-parameter :promote-to-double))
428
429
430
431
432
      (push (car key) result)
      (push (second key) result))))

(defun f2cl-compile (filename &rest all-keys
		     &key
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
		     error-file
		     (keep-lisp-file t)

		     (output-file (compile-file-pathname filename))
		     prune-labels
		     include-comments
		     (auto-save t)
		     (relaxed-array-decls t)
		     (coerce-assigns :as-needed)
		     (array-type :array)
		     (array-slicing t)
		     (package :common-lisp-user)
		     declaim
		     declare-common
		     (float-format *read-default-float-format*)
		     common-as-array
449
		     copy-array-parameter
450
		     promote-to-double
451
		     &allow-other-keys)
rtoy's avatar
rtoy committed
452
453
  "Convert the Fortran to Common Lisp and compile the resulting Lisp file

454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
  FILENAME                 File containing Fortran code

  :OUTPUT-FILE             File to contain Lisp code

  :VERBOSE                 verbose output. Default = NIL.
  :PRUNE-LABELS            Prune unused labels. Default = NIL.
  :INCLUDE-COMMENTS        Include Fortran comments in the Lisp output (May be
			    buggy.) Default = NIL
  :AUTO-SAVE               Variables in DATA statements are automatically SAVE'd.
			    Default = T.
  :RELAXED-ARRAY-DECLS     Declarations of array sizes are relaxed in formal
			   parameters to functions.  Default = T.
  :COERCE-ASSIGNS          If T or :ALWAYS, all assignment statements
			    automatically coerce the RHS to the
			    appropriate type for the assignment.  If NIL
			    or :NEVER, coercion never happens.
			    Otherwise, coercion happens as needed.  The
			    Default = :AS-NEEDED

  :KEEP-LISP-FILE          If T, the converted Lisp file is not deleted.
			    Default = NIL.
  :ARRAY-TYPE              The type of array f2cl should use.  Should be
			    'simple-array or 'array.
  :ARRAY-SLICING           When non-NIL, f2cl assumes that, whenever we do an
			    array reference in a call to a subroutine or
			    function, we are really passing a subarray
			    to the routine instead of just the single
			    value.
  :PACKAGE                 A string or symbol specifying what package the
			    result code should be in. (Basically puts a
			    (in-package <p>) at the top.)  Default:
			    :common-lisp-user.
  :DECLAIM                 Declaim compilation options  (Basically puts a
			    (declaim <declaim>) at the top.)
  :DECLARE-COMMON          When non-NIL, any structures for common blocks
			    are declared here.  Otherwise, the
			    structures for the common blocks are not
			    declared.
  :FLOAT-FORMAT            Float format to use when printing the result.
			    Default is *READ-DEFAULT-FLOAT-FORMAT*
  :COMMON-AS-ARRAY         Common blocks are created as a set of arrays, and the
			    common block variables are offsets into the
			    arrays.  This mimics Fortran common block
			    layouts.  Default = NIL.
  :COMMON-BLOCK-FILE       If common blocks are to be declared, then
			    each common block is written to a file whose name
			    is the name of the common block, with the extension
			    \"cmn\"
  :COPY-ARRAY-PARAMETER    In some Fortran code an array of one type is passed to
			    a routine expecting a different type.  F2CL implements
			    this by creating an array and copying the data.  The
			    default is not to copy since it is relatively slow.
506
507
  :PROMOTE-TO-DOUBLE       Promote REAL and COMPLEX constants, variables, and
                            arrays to REAL*8 and COMPLEX*16 types. 
rtoy's avatar
rtoy committed
508
509
510
511
512
513
514
"
  (let ((lisp-file
	 (f2cl filename :prune-labels prune-labels :include-comments include-comments
	       :auto-save auto-save :relaxed-array-decls relaxed-array-decls
	       :coerce-assigns coerce-assigns
	       :array-type array-type
	       :array-slicing array-slicing
rtoy's avatar
rtoy committed
515
	       :package package :declaim declaim
516
	       :declare-common declare-common
517
	       :float-format float-format
518
	       :common-as-array common-as-array
519
520
	       :copy-array-parameter copy-array-parameter
	       :promote-to-double promote-to-double))
521
	(*read-default-float-format* float-format))
522
523
524
525
526
527
528
529
530
    (let ((compiler-keys (remove-f2cl-keys all-keys)))
      (multiple-value-prog1
	  #+(or cmu scl)
	  (apply #'compile-file lisp-file :output-file output-file
		 :error-file error-file compiler-keys)
	  #-(or cmu scl)
	  (apply #'compile-file lisp-file :output-file output-file compiler-keys)
	  (unless keep-lisp-file
	    (delete-file lisp-file))))))
rtoy's avatar
rtoy committed
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
;---------------------------------------------------------------------------
(defun process-data (x) 
   (print x)
   (fortran-to-lisp 
     (concatenate 'string 
        "[.xnr]" (string-downcase (princ-to-string x)) ".for")
     (concatenate 'string 
        "[.lnr]" (string-downcase (princ-to-string x)) ".l")))
;-----------------------------------------------------------------------------  
; not the same as Senac's concat:
 (defun concaten (x &rest more-args)
  (intern
    (apply #'concatenate 'string
      (princ-to-string x) (mapcar #'princ-to-string more-args)) 
    (find-package :user)))
;----------------------------------------------------------------------------
  
; utilities
;	fortran-to-lisp
;       readsubprog-extract-format-stmts
;       translate-and-write-subprog
;	translate-line
;	setsyntax
;	single-macro-character
;	set-fortran-read
;	setlispread
;	lineread
;	read-six-chars
;	introduce-continue
;	find-do
;----------------------------------
; identifiers
;       id-definition-prog
;	id-definition-sub
;	id-definition-fun-typed
;	id-definition-fun
;	id-declaration
;	id-parameter
;       id-implicit-decl
;	id-assignment
;	id-subroutine-call
;	id-do-loop
;       id-pause
;       id-return
;       id-predicate
;	id-if
;	id-endif
;       id-if-goto
;	id-if-then
;	id-goto
;       id-continue
;-----------------------------------
; parsers
;       parse-prog-definition
;	parse-subr-definition
;       parse-typed-fun-definition
;       parse-fun-definition
;       parse-declaration
;       parse-implicit-decl
;	parse-parameter
;	parse-assignment
;	parse-expression
;       parse-pause
;	parse-subroutine-call
;	parse-do-loop
;	parse-if
;       parse-if-goto
;	parse-if-then
;	parse-return
;	parse-goto
;       parse-save
;       parse-common
;       parse-char-decl
;       parse-data
;       parse-data1
;	princ-reset
;-------------------------------------
; parsing utilities
;       extract-atoms
;       tail-chop
;       head-chop
;       list-split
;       gen-list-split
;       list-split-multi
;       list-split-bin
;       concat-operators
;       brackets-check
;	subsequence
;-------------------------------------
; matching
;	binding-value
;	variablep
;	variable-value
;	unify - returns fail or a bindings list/nil
;	match - returns multiple values or nil
;	maybe-extend-bindings
;------------------------------------------------------------------------------

629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
(defun print-header (outport declaim package options)
  ;; Print a header to the file indicating when this was
  ;; compiled and the version of f2cl used to compile it.
  ;; Include the options used to compile the file.
  (let ((version-info (f2cl-version)))
    (pprint-logical-block (outport version-info :per-line-prefix ";;; ")
      (format outport "Compiled by f2cl version:~%")
      (write version-info :stream outport)))
  (format outport "~2%;;; Using Lisp ~A ~A~%"
	  (lisp-implementation-type) (lisp-implementation-version))
  (let ((*print-case* :downcase))
    ;; Insert in-package and declaim, if needed
    (when options
      (pprint-logical-block (outport options :per-line-prefix ";;; ")
	(format outport "~&Options: ")
	(write options :stream outport :case :downcase))
      (format outport "~2%"))
    (when package
      (format outport "~&(in-package ~S)~%" (cond ((keywordp package)
						   package)
						  ((symbolp package)
						   (string package))
						  ((packagep package)
						   (package-name package))
						  (t
						   package))))
    (when declaim
      (write (list 'declaim declaim) :stream outport :case :downcase))
    (when (or package declaim)
      (format outport "~2%"))
    ;;(format outport "~2&(use-package :f2cl)~2%")
    ))

662
(defun fortran-to-lisp (file ofile &key declaim package options)
rtoy's avatar
rtoy committed
663
  (let ((*package* (find-package :f2cl))
664
665
666
667
668
	;; We need to read in numbers in single-float format because
	;; Fortran literals are single precision unless an exponent
	;; marker is given.  However, when writing, we honor
	;; *float-format* so that the generated output has the desired
	;; style for printed numbers.
669
	(*read-default-float-format* (maybe-promote-type 'single-float))
670
	*common_array_dims* *format_stmts* *statement-labels*)
rtoy's avatar
rtoy committed
671
672
    (when *verbose*
      (format t "beginning the main translation ...~%"))
rtoy's avatar
rtoy committed
673
674
    (with-open-file (inport file :direction :input)
      (with-open-file (outport ofile :direction :output 
rtoy's avatar
rtoy committed
675
			       :if-exists :rename-and-delete)
rtoy's avatar
rtoy committed
676
        (setq *common_array_dims* nil)
rtoy's avatar
rtoy committed
677
678
679
        (do ((char (peek-char nil inport nil 'eof) 
                   (peek-char nil inport nil 'eof)))
            ((eq char 'eof) )
rtoy's avatar
rtoy committed
680
          (setq *format_stmts* nil)
681
	  (setq *statement-labels* nil)
rtoy's avatar
rtoy committed
682
683
	  (let ((*print-level* nil)
		(*print-length* nil))
684
685
686
	    ;; Print a header to the file indicating when this was
	    ;; compiled and the version of f2cl used to compile it.
	    ;; Include the options used to compile the file.
rtoy's avatar
rtoy committed
687
	    (translate-and-write-subprog 
688
	     (introduce-continue
689
	      (readsubprog-extract-format-stmts inport))
690
691
692
693
694
	     outport
	     ofile
	     declaim
	     package
	     options))))))
rtoy's avatar
rtoy committed
695
696
697
698
699
700
701
702
  t)

;---------------------------------------------------------------------------

(defun single-macro-character (stream char)
  (declare (ignore stream))
  (let ((x (intern (string char)))) x))

rtoy's avatar
rtoy committed
703
(defparameter *fortran-readtable*
rtoy's avatar
rtoy committed
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
  (let ((*readtable* (copy-readtable nil)))
    #+scl
    (ecase ext:*case-mode*
      (:upper (setf (readtable-case *readtable*) :upcase))
      (:lower (setf (readtable-case *readtable*) :downcase)))
    (flet ((setsyntax (x)
	     (set-macro-character x #'single-macro-character)))
      (setsyntax #\,)
      (setsyntax #\:)
      (setsyntax #\*)
      (setsyntax #\=)
      (setsyntax #\/)
      (setsyntax #\+)
      (setsyntax #\-)
      (setsyntax #\^)
      (setsyntax #\<)
      (setsyntax #\>)
      (setsyntax #\[)
      (setsyntax #\])
      (setsyntax #\()
      (setsyntax #\))
      (setsyntax #\{)
      (setsyntax #\})
      (setsyntax #\!)
      ;; reserved characters:
729
730
731
      ;;
      ;; Note: Some Fortran compilers (Sun Studio) allow $ as a valid
      ;; character.
rtoy's avatar
rtoy committed
732
733
734
735
736
737
738
      (setsyntax #\$)
      (setsyntax #\@) 
      (setsyntax #\&) 
      (setsyntax #\~) 
      (setsyntax #\')
      (setsyntax #\|)
      (setsyntax #\`)
rtoy's avatar
rtoy committed
739
      (setsyntax #\#)
rtoy's avatar
rtoy committed
740
741
742
      ;; Why do we have to handle \ specially here?
      #+nil (setsyntax #\\)
      )
rtoy's avatar
rtoy committed
743
744
745
746
747
748
    *readtable*))

(defmacro with-fortran-syntax (&body body)
  `(let ((*readtable* *fortran-readtable*))
     ,@body))

rtoy's avatar
rtoy committed
749
;-----------------------------------------------------------------------------
750
#+nil
rtoy's avatar
rtoy committed
751
(defun readsubprog-extract-format-stmts (inport)
752
753
754
755
756
757
758
759
760
761
762
763
764
765
  (let (input-list output-list margin *current_label*)
    (when *verbose*
      (format t "~&extracting format statements ...~%"))

    (loop
	;; Get the left margin (contains line number)
	(setq margin (unless (eq (peek-char nil inport nil 'eof) 'eof)
		       (read-six-chars inport)))
	;; Set the label (line number), if any
	(setq *current_label*
	      (let ((label (read-from-string (coerce margin 'string) nil)))
		(if (integerp label)
		    label)))
        ;; Make sure we aren't hosed if we break out of this!
rtoy's avatar
rtoy committed
766
767
768
769
770
771
772
	(with-fortran-syntax
	  ;; read body of a line
	  (setq input-list (lineread inport))
	  ;; read newline character
	  (read-char inport nil 'eof t)
	  ;; (format t "~% input-list: ~S" input-list)
	  )
773
774
        ;; extract format-stmts
        ;;(format t "extract format-stmts~%")
rtoy's avatar
rtoy committed
775
	(if (eq (car input-list) 'format)
776
777
778
779
780
	    (parse-format (brackets-check (concat-operators input-list)))
	    (push (list *current_label* input-list) output-list))
	;; Check for end of subprogram
	(if (and (eq (car input-list) 'end) (null (cdr input-list)))
	    (return (nreverse output-list))))))
781

782
783
784
785
;; An extended DO statement is a DO statement without the following
;; line number.
(defun id-extended-do (line)
  (and (eq (first line) 'do)
rtoy's avatar
rtoy committed
786
787
788
789
790
791
792
793
794
795
796
797
798
       (not (numberp (second line)))
       (not (eq (second line) 'while))))

;; The DO-WHILE extension.  This looks something like
;;
;; DO <label> WHILE (<expr>)
;;
;; So we just make sure we have DO and WHILE and an optional label.
(defun id-do-while (line)
  (and (eq (first line) 'do)
       (or (eq (second line) 'while)
	   (and (numberp (second line))
		(eq (third line) 'while)))))
799
800
801
802

(defun rewrite-extended-do (label line)
  `(,(first line) ,label ,@(rest line)))

rtoy's avatar
rtoy committed
803
804
805
806
807
808
809
810
811
812
813
814
(defun rewrite-do-while (label1 label2 line)
  ;; "do while (cond)" becomes
  ;; "label1 if (.not. (cond)) goto <label2>"
  ;;
  ;; But
  ;;
  ;; "do <l1> while (cond) becomes
  ;; "label1 if (.not. (cond)) goto <l1>"
  (if (integerp (second line))
      `(if |(| not ,@(cdddr line) |)| goto ,label2)
      `(if |(| not ,@(cddr line) |)| goto ,label2)))

815
816
817
818
819
820
821
822
;; Find an END DO or ENDDO statement
(defun id-end-do (x)
  (or (eq (car x) 'enddo)
      (and (eq (car x) 'end)
	   (eq (cadr x) 'do))))

;; Find a WRITE statement where the format is not a statement number
;; but a string giving the format itself.
rtoy's avatar
rtoy committed
823
#+nil
824
(defun id-write-format (input-list)
825
826
827
828
829
830
831
832
833
834
  (when (eq (car input-list) 'write)
    ;; A write statement looks like the following, so try to match one
    ;; of these patterns:
    ;; 
    ;; (write |(| unit |,| 'foo' |)| ...
    ;; (write |(| unit |,| fmt = 'foo' |)| ...
    (or (stringp (fifth input-list))
	(and (eq 'fmt (fifth input-list))
	     (eq '= (sixth input-list))
	     (stringp (seventh input-list))))))
835

836
(defun readsubprog-extract-format-stmts (inport)
837
838
  (let ((extended-label 100000)		; Must be bigger than any possible valid Fortran label.
	(extended-do-label-stack '())
839
	input-list output-list margin *current_label*)
840
841
842
843
844
845
846
847
848
849
850
    (when *verbose*
      (format t "~&extracting format statements ...~%"))
    (loop
	;; Get the left margin (contains line number)
	(setq margin (unless (eq (peek-char nil inport nil 'eof) 'eof)
		       (read-six-chars inport)))
	;; Set the label (line number), if any
	(setq *current_label*
	      (let ((label (read-from-string (coerce margin 'string) nil)))
		(if (integerp label)
		    label)))
851
852
853
        ;; Add to list
        (when *current_label*
	  (push *current_label* *statement-labels*))
rtoy's avatar
rtoy committed
854
855
856
857
858
859
860
861
	;; Make sure we aren't hosed if we break out of this!
	(with-fortran-syntax
	  ;; read body of a line
	  (setq input-list (lineread inport))
	  ;; read newline character
	  (read-char inport nil 'eof t)
	  ;;(format t "~% input-list: ~S" input-list)
	  )
862
863
      ;; extract format-stmts
      ;;(format t "extract format-stmts~%")
864
	       
865
866
867
868
869
870
871
872
873
874
875
876
877
      (cond ((id-extended-do input-list)
	     ;; Handle extended DO statements.  These are DO
	     ;; statements that do not have a line number.  The DO
	     ;; statement is ended with an END-DO statement.
	     ;;
	     ;; We handle these by faking it. We create a standard
	     ;; DO statement with a new label.  The matching ENDDO
	     ;; statement is converted into a corresponding CONTINUE
	     ;; statement with the correct label.  The label is just
	     ;; an integer bigger than any allowable Fortran label
	     ;; (99999), since Fortran labels are limited to 5
	     ;; digits.
	     (push extended-label extended-do-label-stack)
878
	     (push `(,*current_label* ,(rewrite-extended-do extended-label input-list))
879
880
881
		   output-list)
	     (incf extended-label))
	    ((id-do-while input-list)
rtoy's avatar
rtoy committed
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
	     ;; Handle do-while statements.
	     ;;
	     ;; We handle this by faking it.
	     ;;
	     ;; do while (cond)
	     ;;   <stuff>
	     ;; end do
	     ;;
	     ;; <label1> if (.not. (cond)) goto <label2>
	     ;;            <stuff>
	     ;;          goto <label1>
	     ;; <label2> continue
	     ;;
	     ;; So we need to push label1 and label2 onto our label
	     ;; stack.  Then rewrite the line with what we want.
	     (let ((label1 extended-label)
		   (label2 (if (integerp (second input-list))
			       (second input-list)
			       (incf extended-label))))
	       (incf extended-label)
	       (push (list label1 label2) extended-do-label-stack)
	       (push `(,label1 ,(rewrite-do-while label1 label2 input-list))
		     output-list)))
905
	    ((id-end-do input-list)
rtoy's avatar
rtoy committed
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
	     ;; The end of the extended DO statement.  This can either
	     ;; be the end of an extended do loop or a do-while loop.
	     ;; Figure out what do do.  For a do-loopk, 
	     (let ((label (pop extended-do-label-stack)))
	       (cond ((numberp label)
		      ;; We have a do-loop.  Convert to a standard
		      ;; continue statement with the correct label.
		      (push `(,label (continue))
			    output-list))
		     ((consp label)
		      ;; We have a do-while loop.  We need to replace
		      ;; this with "goto <label1>" and "<label2>
		      ;; continue".
		      (destructuring-bind (l1 l2)
			  label
			(push `(nil (goto ,l1)) output-list)
			(push `(,l2 (continue)) output-list))))))
rtoy's avatar
rtoy committed
923
	    #+nil
924
925
926
927
	    ((id-write-format input-list)
	     ;; We have a write statement where the format isn't a
	     ;; label but a string.  Convert this to a label and add
	     ;; a format statement.
928
929
930
931
932
933
934
935
936
	     (let ((new
		    ;; Rewrite a WRITE statement with FMT as if it
		    ;; weren't.
		    (if (eq 'fmt (fifth input-list))
			`(write |(| ,(third input-list) |,| ,extended-label |)|
				,@(nthcdr 8 input-list))
			`(write |(| ,(third input-list) |,| ,extended-label |)|
				,@(nthcdr 6 input-list)))))
	       (push `(,*current_label* ,new) output-list))
937
938
939
	     (setf *current_label* extended-label)
	     (incf extended-label)
	     ;; Convert the string format into the appropriate format
rtoy's avatar
rtoy committed
940
	     (let ((fmt (with-fortran-syntax
941
			  ;; read body of a line
rtoy's avatar
rtoy committed
942
943
944
945
946
947
			  (lineread
			   (make-string-input-stream
			    (process-format-line
			     (if (eq 'fmt (fifth input-list))
				 (seventh input-list)
				 (fifth input-list))))))))
948
949
	       (setf input-list `(format ,@fmt))
	       (parse-format (brackets-check (concat-operators input-list)))))
rtoy's avatar
rtoy committed
950
	    ((eq (car input-list) 'format)
951
952
953
954
955
956
957
958
959
960
	     (parse-format (brackets-check (concat-operators input-list))))
	    (t
	     (push (list *current_label* input-list) output-list)))
	
      ;; Check for end of subprogram
      (when (and (eq (car input-list) 'end) (null (cdr input-list)))
	(when extended-do-label-stack
	  (warn "An extended DO statement is missing its matching ENDDO statement"))
	(return (nreverse output-list))))))

rtoy's avatar
rtoy committed
961
962
963
964
965
966
967
968
;------------------------------------------------------------------------------
(defun introduce-continue (prog-list) ; ((margin line) (margin line) ...)
 (prog (ret labels next rest)
  (setq labels (remove nil (mapcar #'find-do prog-list)))
  (setq next (first prog-list) rest (rest prog-list))
  loop
  (if (and (member (car next) labels)
           (multiple-do-labelp 
rtoy's avatar
rtoy committed
969
              (concatenate 'string (symbol-name :label)
rtoy's avatar
rtoy committed
970
971
972
973
974
975
976
977
978
                           (princ-to-string (car next))) labels))
      (setq ret (append  (list (list (car next) '(continue)))
                         (list (list nil (second next)))  ret))
      (setq ret (cons next ret)))
 (if (null rest) (return (reverse ret)))
 (setq next (car rest) rest (cdr rest))
 (go loop)))

(defun find-do (margin-line)
979
980
981
982
  (if (eq (caadr margin-line) 'do)
      (cadadr margin-line)
      nil))

983
984
985
986
987
988
989
;; Now look through the tree of code and replace every symbol in the
;; f2cl library with the symbol actually from the library.  (This is
;; currently quite expensive because we look through the entire tree
;; for every symbol.  We should traverse the tree just once and look
;; at each symbol to see if it needs replacing.  Should profile this
;; to see if this really matters.)

990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
(defun fixup-f2cl-lib (tree external-names)
  ;; F2CL provides it's own implementation of d1mach, r1mach, and
  ;; i1mach.  So if the Fortran code declares these as external, we
  ;; remove them.  This assumes that d1mach and friends really is the
  ;; standard SLATEC d1mach.
  (let ((external-names (remove-if #'(lambda (s)
				       (member s '(d1mach r1mach i1mach)))
				   external-names)))
    (do-external-symbols (lib-sym :f2cl-lib)
      (unless (member lib-sym external-names :test #'(lambda (a b)
						       (string-equal (symbol-name a)
								     (symbol-name b))))
	(setf tree (subst lib-sym lib-sym tree
			  :test #'(lambda (a b)
				    (and (symbolp a)
					 (symbolp b)
					 (string-equal a b)))))))
    tree))
1008

rtoy's avatar
rtoy committed
1009
1010
;------------------------------------------------------------------------------
; prog-list of form ((margin line) (margin line) ...)
1011

1012
#+nil
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
(defun maybe-nullify-returns (ret-values)
  ;; If the return values are not members of *assigned-variables*,
  ;; that means the var was never assigned, so we can return NIL
  ;; instead of the variable.
  (mapcar #'(lambda (v)
	      (if (member v *assigned-variables*)
		  v
		  nil))
	  ret-values))

1023
1024
1025
1026
1027
(defun maybe-nullify-returns (fcn-name arg-names)
  ;; If the return values are not members of *assigned-variables*,
  ;; that means the var was never assigned, so we can return NIL
  ;; instead of the variable.
  (let ((arg-types nil)
1028
1029
	(ret-vals nil)
	(entry (gethash fcn-name *f2cl-function-info*)))
1030
1031
1032
1033
    (dolist (v arg-names)
      (push (if (member v *assigned-variables*)
		v
		nil)
1034
1035
	    ret-vals)
      )
1036
    (setf ret-vals (nreverse ret-vals))
1037
1038
1039
1040
1041
    (if entry
	(setf (f2cl-finfo-return-values entry) ret-vals)
	(setf (gethash fcn-name *f2cl-function-info*)
	      (make-f2cl-finfo :return-values ret-vals
			       :arg-types arg-types)))
1042
1043
1044
    ret-vals))


1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
(defun output-common-block (spec-proc spec-decl outport
			    output-path declaim package options)
  (labels
      ((do-core (port s-proc s-decl)
	 (setf s-proc (fixup-f2cl-lib s-proc *external-function-names*))
	 (special-print s-proc port)
	 (terpri port)
	 (format port "~%~%")
	 (setf s-decl (fixup-f2cl-lib s-decl *external-function-names*))
	 (special-print s-decl port)
	 (terpri port)
	 (format port "~%~%")
	 (pushnew (caadr s-proc) *common-block-initialized*))
       (do-file ()
	 (let (filenames)
	   (mapc
	    #'(lambda (s-proc s-decl)
		(unless (find (caadr s-proc) *common-block-initialized*)
		  (let* ((cname (caadr s-proc))
			 (file (make-pathname
				:name (string-downcase (string cname))
				:type "cmn"
				:defaults output-path)))
		    (push file filenames)
		    (with-open-file (port file
					  :direction :output
					  :if-exists :supersede)
				
		      (format port ";;; -*- Mode: lisp -*-~2%")
		      (print-header port declaim package options)
		      (format port "~2%;;; Common block specification~%")
		      (do-core port s-proc s-decl)))))
	    spec-proc
	    spec-decl)
	 filenames))
       (do-output (port)
	 (mapc
	  #'(lambda (s-proc s-decl)
	      (unless (find (caadr s-proc) *common-block-initialized*)
		(do-core port s-proc s-decl)))
	  spec-proc
	  spec-decl)))
    (if *common-block-file*
	(do-file)
	(do-output outport))))

(defun translate-and-write-subprog (prog-list outport output-path
				    declaim package options)
1093
  (clrhash *common-blocks*)
1094
  (clrhash *f2cl-statement-finfo*)
1095
1096
1097
1098
1099
1100
  (let ((labels (remove nil (mapcar #'find-do prog-list))) ; labels is
							   ; the list
							   ; of do
							   ; integers
	;; Setup default list of intrinsic functions
	(*intrinsic-function-names* (copy-list *default-intrinsic-function-names*))
1101
	fort-fun *external-function-names*
1102
1103
	*undeclared_vbles* *declared_vbles* *implicit_vble_decls* *explicit_vble_decls*
	*save_vbles* *key_params* *subprog_common_vars* 
1104
	*subprog-stmt-fns* *subprog_stmt_fns_bodies* *subprog_name*
1105
1106
1107
	*function-flag* *program-flag*
	*subprog-arglist* *data-init* *functions-used* *vble-declaration-done*
	*parsing-lhs*
1108
	*equivalenced-vars*
1109
	*common_array_dims*
1110
	*declared-intrinsic-names*)
1111
1112

    (print-header outport declaim package options)
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
     (setq fort-fun
	   (do ((lines prog-list (cdr lines)) 
		(fort-fun nil (append fort-fun
				      (append (translate-label (caar lines))
					      (translate-line 
					       (brackets-check (concat-operators
								(cadar lines))))))))
	       ((null (cdr lines))
		(append fort-fun
			(cond (*function-flag*
			       ;; A function.  Return the value of the
			       ;; function, the value of the variable
			       ;; with the same name as the function.
1126
1127
			       `(end_label
				 (return (values ,(cadr fort-fun)
1128
						 ,@(mapcar #'first *entry-points*)
1129
						 ,@(maybe-nullify-returns (second fort-fun) (caddr fort-fun))))))
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
			      ((or *program-flag*
				   (not (eq (car fort-fun) 'defun)))
			       ;; Return nil if this is the main
			       ;; program, indicated by either having
			       ;; a PROGRAM statement (*program-flag*
			       ;; set) or no DEFUN in FORT-FUN.
			       `(end_label (return nil)))
			      (t
			       ;; A subroutine definition.  Return the
			       ;; arguments of the subroutine.
			       `(end_label (return (values 
1141
						    ,@(maybe-nullify-returns (second fort-fun) (caddr fort-fun)))))))))))
1142

1143
1144
1145
1146
1147
     ;; check for missing PROGRAM stmt
     (if (not (eq (car fort-fun) 'defun))
         (setq fort-fun (append '(defun *main* nil) fort-fun)))
     ;;     (format t "~%after translation : ~A" fort-fun)

rtoy's avatar
rtoy committed
1148
1149
     (multiple-value-bind (spec-proc spec-decl fun)
	 (insert-declarations (prune-labels (fix-structure fort-fun labels)))
1150
1151
1152
1153
1154
       #+nil
       (let ((*package* (find-package '#:cl-user)))
	 (format t "spec-proc = ~S~%" spec-proc)
	 (format t "spec-decl = ~S~%" spec-decl)
	 (format t "fun = ~S~%" fun))
rtoy's avatar
rtoy committed
1155
       (when spec-proc
1156
1157
1158
	 (setf *common-block-file-names*
	       (output-common-block spec-proc spec-decl outport
				    output-path declaim package options)))
1159

1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
       #+nil
       (let ((*package* (find-package '#:cl-user)))
	 (format t "fun = ~S~%" fun))
       
       ;; Add the function name to the list of external function names
       ;; because we don't want to mangle the function name.  This is
       ;; to prevent some Fortran code from redefining our library
       ;; functions, in case the Fortran code has declared them as
       ;; external.
       (setf fun (fixup-f2cl-lib fun (cons (cadr fort-fun) *external-function-names*)))
1170

1171
       (special-print fun outport)
1172
       (format outport "~2&(in-package #-gcl #:cl-user #+gcl \"CL-USER\")~%#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))~%")
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
       (let* ((*package* (find-package '#:cl-user))
	      (fname (second fort-fun))
	      (info (gethash fname *f2cl-function-info*)))
	 (write `(eval-when (:load-toplevel :compile-toplevel :execute)
		   (setf (gethash ',fname *f2cl-function-info*)
			 (make-f2cl-finfo :arg-types ',(f2cl-finfo-arg-types info)
					  :return-values ',(f2cl-finfo-return-values info)
					  :calls ',(f2cl-finfo-calls info))))
		:stream outport
		:pretty t
		:case :downcase
1184
		:circle nil
1185
		:readably t)))
rtoy's avatar
rtoy committed
1186
     (print (cadr fort-fun))		;indicate which subprogram is being translated
rtoy's avatar
rtoy committed
1187
1188
     (write-char '#\newline outport)
     (write-char '#\newline outport)
rtoy's avatar
rtoy committed
1189
     ))
rtoy's avatar
rtoy committed
1190
1191

;=============================================================================
1192
1193
1194
(defparameter *f2cl-pprint-dispatch*
  (copy-pprint-dispatch))

rtoy's avatar
rtoy committed
1195
(defun special-print (x o)
1196
1197
1198
1199
1200
  (with-standard-io-syntax
    (let ((*package* (find-package :f2cl))
	  (*print-pretty* t)
	  (*print-case* :downcase)
	  (*print-circle* nil)
1201
1202
1203
1204
	  ;; Clisp basically seems ignores all other settings and
	  ;; tries very, very hard to make sure what's written is read
	  ;; back in exactly the same way if *print-readably* is non-NIL.
	  (*print-readably* nil)
1205
1206
	  ;; Write out the code using the desired floating-point
	  ;; format.
1207
1208
	  (*read-default-float-format* *float-format*)
	  (*print-pprint-dispatch* *f2cl-pprint-dispatch*))
1209
      (write x :stream o))))
rtoy's avatar
rtoy committed
1210
;------------------------------------------------------------------------------
rtoy's avatar
rtoy committed
1211
1212
1213
(defun princ-reset (x &optional (y ""))
  (print x)
  (princ y))
rtoy's avatar
rtoy committed
1214
1215
1216
1217

(defun translate-label (label)
   (if label 
       (list (read-from-string
rtoy's avatar
rtoy committed
1218
1219
                  (concatenate 'string (symbol-name :label) (princ-to-string label))
		  nil))
rtoy's avatar
rtoy committed
1220
1221
1222
1223
       nil))

;------------------------------------------------------------------------------

rtoy's avatar
rtoy committed
1224
1225
1226
1227
1228
1229
(defun translate-line (x)
  ;; x is a list being a line body-> list of lisp
  (prog (bindings)
     ;; reduce any DOUBLE PRECSION, REAL*8 etc to one word data types
     (when (member (car x) '(double real integer complex)) 
       (setq x (reduce-data-type x)))
1230
1231
1232
     (when *verbose*
       (write x :case :downcase)
       (terpri))
rtoy's avatar
rtoy committed
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262

     ;;return
     (when (id-return x)
       (return '((go end_label))))
     ;;continue
     (setq bindings (id-continue x))
     (when (not (eq bindings 'fail))
       (return `(continue_place_holder)))
     ;;definition
     (setq bindings (id-definition-prog-name x))
     (when (not (eq bindings 'fail))
       (return (parse-prog-definition bindings)))
     (setq bindings (id-definition-prog x))
     (when (not (eq bindings 'fail))
       (return (parse-prog-definition bindings)))
     (setq bindings (id-definition-sub x))
     (when (not (eq bindings 'fail))
       (return (parse-subr-definition bindings)))
     (setq bindings (id-definition-fun x))
     (when (not (eq bindings 'fail))
       (return (parse-fun-definition bindings)))
     (setq bindings (id-definition-fun-typed x))
     (when (not (eq bindings 'fail))
	
       (return (parse-typed-fun-definition bindings)))
     ;;goto/go to
     (when (id-comp-goto x)
       (return (parse-comp-goto x)))
     (when (id-comp-go-to x)
       (return (parse-comp-go-to x)))
rtoy's avatar
rtoy committed
1263
1264
     (when (id-assign x)
       (return (parse-assign x)))
rtoy's avatar
rtoy committed
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
     (when (id-assgn-goto x)
       (return (parse-assgn-goto x)))
     (setq bindings (id-goto x))
     (when (not (eq bindings 'fail))
       (return (parse-goto bindings)))
     (when (id-assgn-go-to x)
       (return (parse-assgn-go-to x)))
     (setq bindings (id-go-to x))
     (when (not (eq bindings 'fail))
       (return (parse-goto bindings)))
     ;;declarations
     (when (id-declaration x)
       (return (parse-declaration x))) 
     ;;parameters
     (when (id-parameter x)
       (return (parse-parameter x)))
     ;;implicit declarations
     (when (id-implicit-decl x)
       (return (parse-implicit-decl x)))
     ;;do loop
     (when (id-do-loop x)
       (return (parse-do-loop (check_new_vbles x))))
1287

rtoy's avatar
rtoy committed
1288
1289
     ;; if-then
     (when (id-if-then x)
1290
1291
1292
1293
       ;; No need to check for new vars here, because I don't think
       ;; there can be.
       (return (parse-if-then x)))
     
rtoy's avatar
rtoy committed
1294
1295
     ;; elseif (or else-if)
     (when (id-elseif x)
1296
1297
       ;; No need to check for new vars here, because I don't think
       ;; there can be.
rtoy's avatar
rtoy committed
1298
       (return `((elseif_place_holder 
1299
		  ,(id-logical (cadr x))))))
rtoy's avatar
rtoy committed
1300
1301
     (when (id-else-if x)
       (return `((elseif_place_holder
1302
1303
		  ,(id-logical (caddr x))))))
     ;; else
rtoy's avatar
rtoy committed
1304
1305
     (when (id-else x)
       (return '((elseif_place_holder t))))
1306
1307

     ;; endif
rtoy's avatar
rtoy committed
1308
1309
1310
1311
1312
1313
1314
1315
     (when (id-endif x)
       (return '(endif_place_holder)))

     ;;if
     (setq bindings (id-if-goto x))
     (when (not (eq bindings 'fail))
       (return (parse-if-goto bindings)))
     (when (id-if x)
1316
1317
1318
1319
1320
1321
       ;; No need to check for new vars here.  There can be new vars
       ;; defined here, but I think parse-if will handle that
       ;; correctly.  This prevents spurious variables from being
       ;; defined, like sqrt$, which comes about because we check
       ;; before we've convert the function SQRT to FSQRT.
       (return (parse-if x)))
rtoy's avatar
rtoy committed
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337

     ;;assignments or statement functions
     (when (id-assignment x)
       (return (parse-assignment x)))
     ;;subroutine call
     (when (id-subroutine-call x) 
       (return (parse-subroutine-call x)))
     ;;pause
     (when (id-pause x)
       (return (parse-pause x)))
     ;;write
     (when (eq (car x) 'write)
       (return (parse-write x)))
     ;;print
     (when (eq (car x) 'print)
       (return (parse-print x)))
1338
1339
1340
     ;; read
     (when (eq (car x) 'read)
       (return (parse-read x)))
rtoy's avatar
rtoy committed
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
       
     ;;format
     (when (eq (car x) 'format)
       (return (parse-format x)))
     ;;data
     (when (eq (car x) 'data)
       (return (parse-data x)))
     ;;save
     (when (eq (car x) 'save)
       (return (parse-save x)))
     ;;intrinsic
     (when (eq (car x) 'intrinsic)
1353
       (return (parse-intrinsic x)))
rtoy's avatar
rtoy committed
1354
1355
1356
1357
1358
1359
1360
1361
     ;;external
     (when (eq (car x) 'external)
       (return (parse-external x)))
     ;;common
     (when (eq (car x) 'common)
       (return (parse-common x)))
     ;;stop
     (when (eq (car x) 'stop)
rtoy's avatar
rtoy committed
1362
       ;; Translate STOP as the stop function.
1363
       (return `((f2cl-lib::stop ,@(rest x)))))
rtoy's avatar
rtoy committed
1364

1365
1366
1367
1368
     ;; Equivalence
     (when (eq (car x) 'equivalence)
       (return (parse-equivalence x)))
     
rtoy's avatar
rtoy committed
1369
1370
     ;; Handle Fortran comments that were converted by the
     ;; preprocessor to be (fortran_comment "comment string").
1371
     ;;
rtoy's avatar
rtoy committed
1372
1373
     ;; Convert it to just a quoted string if possible.  Otherwise
     ;; just leave it as is.
rtoy's avatar
rtoy committed
1374
     (when (eq (car x) 'fortran_comment)
1375
1376
1377
1378
       (return (if (cddr x)
		   (list x)
		   (list (list 'quote (second x))))))
     
rtoy's avatar
rtoy committed
1379
1380
     ;; (return (list '----> (check_new_vbles x)))

1381
1382
1383
     (when (or (eq (car x) 'blockdata)
	       (and (eq (car x) 'block)
		    (eq (second x) 'data)))
rtoy's avatar
rtoy committed
1384
       ;; A block data subprogram.  We cheat and pretend it's a
rtoy's avatar
rtoy committed
1385
       ;; subroutine with a special name. If a name is given, use that
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
       ;; as part of the special name.  Be careful.  If we change the
       ;; name used here, we need to modify f2cl5.l to recognize the
       ;; new name.
       (let* ((name (cond ((eq (car x) 'blockdata)
			   (if (second x)
			       (string (second x))
			       nil))
			  ((eq (car x) 'block)
			   (if (third x)
			       (string (third x))
			       nil))
			  (t
			   nil)))
	      (bdname (if name
rtoy's avatar
rtoy committed
1400
			  (intern (concatenate 'string (symbol-name '#:/blockdata-) name "/"))
1401
1402
			  '/blockdata/)))
	 (setq bindings (id-definition-sub `(subroutine ,bdname)))
rtoy's avatar
rtoy committed
1403
	 (return (parse-subr-definition bindings))))
rtoy's avatar
rtoy committed
1404

1405
     #+nil
1406
     (when (eq (car x) 'entry)
1407
1408
       (format t "ENTRY point: ~A~%" (car x))
       (format t " REST = ~A~%" (rest x))
1409
1410
       (push (rest x) *entry-points*)
       (return (list (second x))))
1411
1412
1413
     (setf bindings (id-definition-entry x))
     (when (not (eq bindings 'fail))
       (return (parse-entry-definition bindings)))
1414

1415
1416
1417
1418
1419
1420
1421
1422
     (when (eq (car x) 'open)
       (return (parse-open x)))

     (when (eq (car x) 'rewind)
       (return (parse-rewind x)))

     (when (eq (car x) 'close)
       (return (parse-close x)))
1423
1424
1425
1426
1427
1428
1429

     ;; Fortran 90 extensions:
     (when (eq (car x) 'exit)
       (return (parse-exit x)))

     (when (eq (car x) 'cycle)
       (return (parse-cycle x)))
1430
     
rtoy's avatar
rtoy committed
1431
     ;;fall out the bottom:
1432
     (warn "F2CL did not translate: ~S" (write-to-string (check_new_vbles x)))
rtoy's avatar
rtoy committed
1433
1434
1435
     (return (list (list 'quote (concatenate ' string  "****NOT TRANSLATED: " 
					       (write-to-string (check_new_vbles x))))))
     ))
rtoy's avatar
rtoy committed
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
;------------------------------------------------------------------------------
;program 
(defun id-definition-prog-name (x) 
  (unify x '(program %name) nil))

(defun id-definition-prog (x) 
  (unify x '(program) nil))

;subroutine s(x,...)
(defun id-definition-sub (x) 
  (prog (bindings)
     (setq bindings (unify x '(subroutine %name %arg-list) nil))
     (if (eq bindings 'fail)
         (setq bindings (unify x '(subroutine %name) nil)))
     (return bindings)))

;type function f(x,...)
(defun id-definition-fun-typed (x) 
  (unify x '(%type function %name %arg-list) nil))

;untyped function f(x,...)
(defun id-definition-fun (x) 
  (unify x '(function %name %arg-list) nil))

1460
1461
1462
(defun id-definition-entry (x)
  (unify x '(entry %name %arg-list) nil))

rtoy's avatar
rtoy committed
1463
1464
1465
1466
1467
; continue
(defun id-continue (x) (unify x '(continue) nil))

;goto label
(defun id-goto (x)
1468
1469
1470
1471
1472
1473
1474
1475
  (unify x '(goto %label) nil))

(defun id-comp-goto-core (x)
  ;; (l1, l2, ...) [,] expr
  (let ((ex (remove '|,| x)))
    (and (listp (first ex))
	 (second x))))

rtoy's avatar
rtoy committed
1476
(defun id-comp-goto (x)
1477
1478
  ;; goto (l1, l2, l3, ...) [,] expr
  (and (eq (first x) 'goto)
1479
       (id-comp-goto-core (cdr x))))
1480

rtoy's avatar
rtoy committed
1481
(defun id-comp-go-to (x)