;; -*- Mode: lisp; Package: F2CL -*- ; f2cl1.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;check ;functions: ; f2cl ; concaten ; f-to-l ;--------------------------------------------------------------------------- (in-package :f2cl) (defvar *verbose* nil) (defvar *comments* nil) (defparameter *f2cl-version* "Use (f2cl-version) instead") (defparameter *f2cl1-version* "$Id: f2cl1.l,v 505dc31bee3e 2013/03/26 03:32:16 toy $") ;; Forward declarations. (defvar *f2cl2-version*) (defvar *f2cl3-version*) (defvar *f2cl4-version*) (defvar *f2cl5-version*) (defvar *f2cl6-version*) (defvar f2cl-lib::*f2cl-macros-version*) (defun f2cl-version () (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*))) (defparameter *default-intrinsic-function-names* '(int ifix idint real float sngl dble cmplx dcmplx ichar char aint dint 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 min1 len index lge lgt lle llt aimag dimag conjg sqrt dsqrt csqrt 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 sinh dsinh cosh dcosh tanh dtanh zsqrt cdabs dconjg dfloat len_trim ) "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.") ;;------------------------------------------------------------------------------ ;; 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! #+(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)) '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 (*))) ;;------------------------------------------------------------------------------ (eval-when (compile load eval) (proclaim '(special *sentable*)) (proclaim '(special *external-function-names* *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* *subprog-stmt-fns* *subprog_stmt_fns_bodies* *prune_labels* *auto-save-data* *functions-used* *vble-declaration-done* ;; 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) *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.) *parsing-lhs* ;; List of statement labels in a subprogram *statement-labels* *declared-intrinsic-names* ))) (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.") (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. ") (defvar *default-lisp-extension* "lisp" "The default extension (file type) for the output file name") (defvar *fortran-extensions* '("f" "for") "A list of possible extensions for Fortran files.") (defvar *declare-common-blocks* nil "When non-NIL, the structures for any common blocks are defined in this file") (defvar *assigned-variables* nil "List of variables that are assigned a value") (defvar *entry-points* nil "List of ENTRY points") (defvar *f2cl-trace* nil) (defvar *float-format* 'single-float) (defvar *common-blocks-as-arrays* nil) (defvar *common-block-file* nil) (defvar *common-block-file-names* nil "List of files created when :common-block-file is enabled") (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.") (defvar *equivalenced-vars* nil "List of equivalenced variables. Each entry of the list is a list consisting of the equivalenced variables.") (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. ") (defvar *promote-to-double* nil "If non-NIL, REAL and COMPLEX variables and arrays are promoted to type REAL*8 and COMPLEX*16") ;; For some reason Allegro needs this eval-when because it complains ;; about undefined slot accessors without this. (eval-when (compile load eval) (defstruct (f2cl-finfo (:constructor %make-f2cl-finfo)) arg-types return-values calls) ) (defun relax-array-decl (decls) (flet ((relax-1 (decl) (cond ((and *relaxed-array-decls* (subtypep decl 'array)) (destructuring-bind (a &optional n l) decl (if (subtypep a 'string) `(,a ,@(mapcar (constantly '*) l)) `(,a ,n ,(mapcar (constantly '*) l))))) (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)) ;; 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)) ;; Hash table of all statement functions (defvar *f2cl-statement-finfo* (make-hash-table)) (defun clear-f2cl-finfo () (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*) (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*))) ;---------------------------------------------------------------------------- (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 copy-array-parameter promote-to-double &allow-other-keys) "Fortran to Common Lisp converter 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

) at the top.) :DECLAIM Declaim compilation options (Basically puts a (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. :PROMOTE-TO-DOUBLE Promote REAL and COMPLEX constants, variables, and arrays to REAL*8 and COMPLEX*16 types. " ;;(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)~%") ;; Check (some) parameters for validity (assert (or (null coerce-assigns) (member coerce-assigns '(:always :never :as-needed t)))) (assert (member array-type '(:simple-array :array))) #+nil (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")) (let ((*verbose* verbose) (*prune_labels* prune-labels) (*comments* include-comments) (*auto-save-data* auto-save) (*common-block-initialized* nil) (*relaxed-array-decls* relaxed-array-decls) (*coerce-assignments* coerce-assigns) (*array-type* (cdr (assoc array-type '((:simple-array . common-lisp:simple-array) (:array . common-lisp:array))))) (*array-slicing* array-slicing) (*apply-array-slice* nil) (*declare-common-blocks* declare-common) (*assigned-variables* nil) (*entry-points* nil) (*equivalenced-vars* nil) (*float-format* float-format) (*common-blocks-as-arrays* common-as-array) (*common-block-file* common-block-file) (*copy-array-parameter* copy-array-parameter) (*promote-to-double* promote-to-double)) (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)))) (unless output-file (let ((input-path (pathname input-file))) (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))))) (format t "~&;; ~S -> ~S~%" input-file output-file) (let ((processed-file (preprocess input-file))) (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) (:array-slicing ,array-slicing) (:declare-common ,declare-common) (:float-format ,float-format))) (unless keep-temp-file (delete-file processed-file)) (values output-file)))) (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 :declaim :declare-common :float-format :common-as-array :common-block-file :copy-array-parameter :promote-to-double)) (push (car key) result) (push (second key) result)))) (defun f2cl-compile (filename &rest all-keys &key 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 copy-array-parameter promote-to-double &allow-other-keys) "Convert the Fortran to Common Lisp and compile the resulting Lisp file 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

) at the top.) Default: :common-lisp-user. :DECLAIM Declaim compilation options (Basically puts a (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. :PROMOTE-TO-DOUBLE Promote REAL and COMPLEX constants, variables, and arrays to REAL*8 and COMPLEX*16 types. " (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 :package package :declaim declaim :declare-common declare-common :float-format float-format :common-as-array common-as-array :copy-array-parameter copy-array-parameter :promote-to-double promote-to-double)) (*read-default-float-format* float-format)) (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)))))) ;--------------------------------------------------------------------------- (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 ;------------------------------------------------------------------------------ (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%") )) (defun fortran-to-lisp (file ofile &key declaim package options) (let ((*package* (find-package :f2cl)) ;; 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. (*read-default-float-format* (maybe-promote-type 'single-float)) *common_array_dims* *format_stmts* *statement-labels*) (when *verbose* (format t "beginning the main translation ...~%")) (with-open-file (inport file :direction :input) (with-open-file (outport ofile :direction :output :if-exists :rename-and-delete) (setq *common_array_dims* nil) (do ((char (peek-char nil inport nil 'eof) (peek-char nil inport nil 'eof))) ((eq char 'eof) ) (setq *format_stmts* nil) (setq *statement-labels* nil) (let ((*print-level* nil) (*print-length* nil)) ;; 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. (translate-and-write-subprog (introduce-continue (readsubprog-extract-format-stmts inport)) outport ofile declaim package options)))))) t) ;--------------------------------------------------------------------------- (defun single-macro-character (stream char) (declare (ignore stream)) (let ((x (intern (string char)))) x)) (defparameter *fortran-readtable* (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: ;; ;; Note: Some Fortran compilers (Sun Studio) allow $ as a valid ;; character. (setsyntax #\$) (setsyntax #\@) (setsyntax #\&) (setsyntax #\~) (setsyntax #\') (setsyntax #\|) (setsyntax #\`) (setsyntax #\#) ;; Why do we have to handle \ specially here? #+nil (setsyntax #\\) ) *readtable*)) (defmacro with-fortran-syntax (&body body) `(let ((*readtable* *fortran-readtable*)) ,@body)) ;----------------------------------------------------------------------------- #+nil (defun readsubprog-extract-format-stmts (inport) (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! (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) ) ;; extract format-stmts ;;(format t "extract format-stmts~%") (if (eq (car input-list) 'format) (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)))))) ;; An extended DO statement is a DO statement without the following ;; line number. (defun id-extended-do (line) (and (eq (first line) 'do) (not (numberp (second line))) (not (eq (second line) 'while)))) ;; The DO-WHILE extension. This looks something like ;; ;; DO