Commit eacbeac8 authored by rtoy's avatar rtoy

Original version.

parent d03883c1
Fortran to Lisp Translation: installation instructions
------------------------------------------------------
1. Go to the f2cl source directory.
2. Use the target Common Lisp compiler to compile each of the files
f2cl1.l through f2cl7.l and macros.l .
3. Edit the file f2cl0.l to reflect the root directory of the
f2cl file system (*f2cl_dir*) and the extension for your Common
Lisp compiled code (*ext*).
4. Load f2cl0.l into Common Lisp.
5. The translator functions are now available to be used.
6. Important note: when compiling or executing translated code the macros
in the file macros.l should be available.
For more information about f2cl, including user instructions, read the
article f2cldoc.* in the f2cl/doc directory or the tests in f2cl/val.
Bugs and comments: senac@waikato.ac.nz
--------------------------------------------------------------------
This diff is collapsed.
; f2cl0.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; edit here so that the root of the f2cl directory tree is appropriate
; for your installation and the filename extension is valid
#+(or sparc sun4)(defvar *f2cl_dir* "/d/sen/f2cl/wrk/")
#+vms (defvar *f2cl_dir* "d:[sen.f2cl.wrk]")
(defvar *ext*
#+clisp ".fas" #+allegro ".fasl" #+vms ".fas" #+lucid ".sbin")
(defun load-f2cl (x)
(load (concatenate 'string *f2cl_dir* x *ext*) :print nil :verbose t))
(load-f2cl "f2cl1" )
(load-f2cl "f2cl2" )
(load-f2cl "f2cl3" )
(load-f2cl "f2cl4" )
(load-f2cl "f2cl5" )
(load-f2cl "f2cl6" )
(load-f2cl "f2cl7" )
(load-f2cl "macros" )
(format t "~&The f2cl software has been loaded.~%")
;-------------------------------------------------------------------------
; end of f2cl0.l
This diff is collapsed.
; f2cl2.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Hamilton, New Zealand 92-95 - all rights reserved;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; functions
; id-expression
; parse
; expression-preparse
; inner-preparse
; id-assignment
; comma-sep-listp - within scope of restrict non-local
; symbol-listp
; id-term
; id-factor
; id-factor1
; gen-list-split
; id-expression-list-ifthen
; id-array-store - check args eval to integers in range at eval time
; restore-negative-numbers
;------------------------------------------------------------------------------
(in-package :user)
(eval-when (compile load eval)
(proclaim '(optimize (speed 3) (safety 1)))
(proclaim '(special f-store arg-store exp-store var-store init-store
next-user-function-address lis-store end-store step-store
body-store intrinsic_function_names external_function_names
subprog_name subprog_stmt_fns)))
;-----------------------------------------------------------------------------
; subst-splice substitutes the list b for the atom a in the list c via splicing
(defun subst-splice (b a c)
(cond ((atom c) c)
((equal (car c) a) (append b (subst-splice b a (cdr c))))
(t (cons (subst-splice b a (car c)) (subst-splice b a (cdr c))))))
;-----------------------------------------------------------------------------
(defun extract (alpha beta)
(prog (retlist)
(setq retlist nil)
loop
(cond ((null beta) (return retlist))
((member (car beta) alpha)
(setq retlist (append1 retlist (car beta))
beta (cdr beta))
(go loop))
(t (setq beta (cdr beta))
(go loop)))))
(defun list-itp (lis signs)
(cond
((member nil lis)
(princ-reset '|f2cl error: failure to parse an expression|)))
(prog (ret)
(cond ((equal signs nil) (return (car lis))))
(setq signs (subst 'f2cl/ '/ signs))
(setq ret (list (car signs) (car lis) (cadr lis)))
(setq lis (cdr lis))
loop
(setq lis (cdr lis))
(setq signs (cdr signs))
(cond ((null (car signs)) (return ret))
(t (setq ret (list (car signs) ret (car lis)))
(go loop)))))
(defun tpl-subst (x y lis)
(cond
((null lis) nil)
((equal y (car lis))
`(,x ,@(tpl-subst x y (cdr lis))))
(t `(,(car lis) ,@(tpl-subst x y (cdr lis))))))
(defun tpl-subpair (lx ly lis)
(prog (elx ely restx resty ret)
(setq elx (car lx) ely (car ly) restx (cdr lx) resty (cdr ly) ret lis)
loop
(setq ret (tpl-subst elx ely ret))
(cond ((null restx) (return ret)))
(setq elx (car restx) ely (car resty) restx (cdr restx) resty (cdr resty))
(go loop)))
;-----------------------------------------------------------------------------
(defun symbol-listp (x) (and (listp x) (symbolp (car x)) (null (cdr x))))
;------------------------------------------------------------------------------
(defun check-tags-go (x)
(prog (tags gos)
(setq tags (mapcar #'car (delete nil (mapcar #'(lambda (y) (cond ((symbol-listp y) y)
(t nil))) x))))
(setq gos (mapcar #'car (find-gos x)))
(return
(cond ((eq (length tags) (length (unique-elements (append gos tags)))) t)
(t nil)))))
;------------------------------------------------------------------------------
(defun find-gos (x)
(cond ((atom x) nil)
((eq (car x) 'go)
(cond ((null (symbol-listp (cadr x)))
(princ-reset
'|f2cl error: the argument to a program "go" must be a valid tag.
Tag being parsed:| (cadr x))))
(list (cadr x)))
(t (append (find-gos (car x)) (find-gos (cdr x))))))
;------------------------------------------------------------------------------
; this didn't solve the fortify problem:
(defun restore-negative-numbers (x)
(prog (rest ret next)
(cond ((not (memberq '- x)) (return x)))
(setq rest x)
loop
(cond ((null rest) (return (reverse ret))))
(setq next (car rest) rest (cdr rest))
(cond ((and (eq '- next) (numberp (car rest)))
(setq ret (cons (minus (car rest)) (cons '+ ret))
rest (cdr rest)))
(t (setq ret (cons next ret))))
(go loop)))
;-----------------------------------------------------------------------------
(defun id-expression (larg)
(prog (x y l)
(setq l (subst-splice '(+ -1 *) '- larg))
(cond ((eq (car l) '+) (setq l (cdr l)))
((eq (car l) '-) (setq l (cons 0 l))))
(setq x (list-split-multi '+ l))
(setq x (list x (extract '(+ -) l)))
(setq y (list-itp (mapcar #'id-term (car x))
(cadr x)))
(return y)))
;-----------------------------------------------------------------------------
(defun id-term (l)
(prog (x)
(setq x (apply #'append (mapcar #'(lambda (x) (list-split-bin '/ x))
(list-split-multi '* l))))
(setq x (list x (extract '(* /) l)))
(if (and (equal (caar x) '(-1)) (equal (cadr x) '(*)))
(return `(- ,(id-factor1 (cadar x)))))
(return (list-itp (mapcar #'id-factor1 (car x))
(cadr x)))))
;-----------------------------------------------------------------------------
(defun id-factor1 (l)
(prog (x)
(setq x (list-split-bin '^ l))
(setq x (list x (extract '(^) l)))
(return (list-itp (mapcar #'id-factor (car x))
(subst 'expt '^ (cadr x))))))
;------------------------------------------------------------------------------
(defun id-factor (l)
(cond
; ((null l) nil)
; number:
((numberp l) l)
; string:
((stringp l) l)
; x.xE%x (scientific notation) number - % is used to represent a minus sign:
((and (symbolp l)
(string-equal
(string-trim '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\.)
(string l))
"E%"))
(setq l
(read-from-string
(concatenate 'string
(string-right-trim
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\%) l)
"-"
(string-left-trim '(#\%)
(string-left-trim
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\. #\E) l)))))
l)
; symbol:
((symbolp l) (check-t-and-pi l))
;number:
((and (null (cdr l)) (numberp (car l))) (car l))
; bracketed symbol or string:
((and (null (cdr l)) (or (symbolp (car l)) (stringp (car l))))
(id-factor (car l)))
; function of no variables:
((and (symbolp (car l)) (eq nil (cadr l)))
(list (car l)))
; boolean expression:
((intersection l '(NOT EQUAL AND OR < > <= >= ><))
(id-logical l))
; intrinsic function call:
((and (symbolp (car l))
(listp (cadr l))
(member (car l) intrinsic_function_names))
(cond ((not (null (cddr l))) (princ-reset
'|f2cl error: missing +, *, /, or ^ operator following a function call.| l)))
(cons (if (eq (car l) 'char) 'fchar (car l)) ;special case intrinsic "char"
(mapcar #'id-expression
(list-split '|,| (cadr l)))))
; array reference:
((and (symbolp (car l)) (listp (cadr l)) (vble-is-array-p (car l)))
(cond ((not (null (cddr l))) (princ-reset
'|f2cl error: missing +, *, /, or ^ operator following a function call.| l)))
(append (list 'fref (car l))
(mapcar #'id-expression
(list-split '|,| (cadr l)))))
; function call:
((and (symbolp (car l)) (listp (cadr l)))
(cond ((member (car l) external_function_names)
`(funcall ,(car l)
,@(mapcar #'id-expression (list-split '|,| (cadr l)))))
; ((member (car l) subprog_stmt_fns)
; `(,(read-from-string
; (concatenate 'string (princ-to-string subprog_name)
; (princ-to-string (car l))))
; ,@(mapcar #'id-expression (list-split '|,| (cadr l)))))
(t
`(,(car l) ,@(mapcar #'id-expression (list-split '|,| (cadr l)))))))
; expression:
((and (listp (car l)) (null (cdr l)))
(id-expression (car l)))
; complex number:
((and (eq (length l) 3) (eq (second l) '|,|))
(list 'complex (id-factor (first l)) (id-factor (third l))))
; error dropping out the bottom:
(t
(princ-reset '|f2cl syntax error| l))
))
;-------------------------------------------------------------------------------
; (a0 |,| a1 |,| a2 ..... |,| an) is checked:
(defun comma-sep-symb-listp (l)
(prog (rest)
(cond
((and
(listp l)
(neq '|,| (car l))
(every #'symbolp l)
(evenp (length (cdr l)))))
(t (return nil)))
(setq rest (cdr l))
loop
(cond ((null rest) (return t)))
(cond ((or (neq (car rest) '|,|)
(eq (cadr rest) '|,|))
(princ-reset
'|f2cl syntax error: failure to parse the parameter list of a function
definition.| l) ))
(setq rest (cddr rest))
(go loop)))
;------------------------------------------------------------------------------
; (a0 |,| a1 |,| a2 ..... |,| an) is checked where a0 are anything :
(defun comma-sep-listp (l)
(prog (rest)
(cond
((and
(listp l)
(neq (car l) '|,|)
(evenp (length (cdr l)))))
(t (return nil)))
(setq rest (cdr l))
loop
(cond ((null rest) (return t)))
(cond ((or (neq (car rest) '|,|)
(eq (cadr rest) '|,|))
(princ-reset
'|f2cl syntax error: failure to parse a list.| l) ))
(setq rest (cddr rest))
(go loop)))
;------------------------------------------------------------------------------
; end of f2cl2.l
; f2cl3.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;Hamilton, New Zeland 1992-95 - all rights reserved;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; pattern matching for the syntax checker
; functions:
; restrict-test
; exact-match
; match-atoms
; match-atoms-lists
; match-store-atoms
; match-store - for atoms and lists
; match-restrict - restricts atoms and matches for lists
; - to use insert (restrict >var predicate) instead of >var or >
; atomcar, atomcdr
; match-separated - matches (a1 s1 a2 s2 ...... an) where the si are
; separators , it delivers a list of two lists, the first being
; a list of lists of the ai and the second a list of the separators
; or returns nil if an ai is missing - this could be used to
; produce a syntax error.
;-----------------------------------------------------------------------------
(in-package :user)
;(declare (localf atomcar atomcdr))
(defun sub-string (x index &optional len)
(cond ((null len) (subsequence x (sub1 index) (length x)))
(t (subsequence x (sub1 index) (min (sub1 (+ index len)) (length x)) ))))
(defun match-separated (separators lis)
(prog (ret)
(setq ret (gen-list-split separators lis))
(cond ((member nil (car ret)) (return nil))
(t (return ret)))))
; exact match
(defun exact-match (p d)
(cond ((and (null p) (null d)) t) ; have we reached the end ?
((equal (car p) (car d)) ; check the first elements
; if not the same return nil
(exact-match (cdr p) (cdr d))))) ; recurse if the same
; match ">" against any atom
; we need a preliminary check to return nil if one list is shorter
(defun match-atoms (p d)
(cond ((and (null p) (null d)) t)
((or (null p) (null d)) nil) ; is one list shorter ?
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-atoms (cdr p) (cdr d)))))
; incorporate the feature of allowing "+" to match against any number of atoms
(defun match-atoms-lists (p d)
(cond ((and (null p) (null d)) t)
((or (null p) (null d)) nil)
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-atoms-lists (cdr p) (cdr d)))
((equal (car p) '+) ; first element + ?
(cond ((match-atoms-lists (cdr p) (cdr d))) ; drop +
((match-atoms-lists p (cdr d))))))) ; keep +
; bind matched atoms to A etc if the pattern has >A
(defun atomcar (a) (nthchar a 1))
(defun atomcdr (a) (concaten (sub-string (symbol-name a) 2)))
(defun match-store-atoms (p d)
(cond ((and (null p) (null d)) t)
((or (null p) (null d)) nil)
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-store-atoms (cdr p) (cdr d)))
((and (equal (atomcar (car p)) '>) ; check for >a
(match-store-atoms (cdr p) (cdr d)))
(set (atomcdr (car p)) (car d)) t) ; bind the pattern variables
; value to the matched atom
((equal (car p) '+)
(cond ((match-store-atoms (cdr p) (cdr d)))
((match-store-atoms p (cdr d)))))))
; bind matched groups of atoms to B if the pattern has +B
; the eval obtains the list of atoms seen so far and the cons adds the atom
; matched at the current level
(defun match-store (p d)
(cond ((and (null p) (null d)) t)
((or (null p) (null d)) nil)
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-store (cdr p) (cdr d)))
((and (equal (atomcar (car p)) '>)
(match-store (cdr p) (cdr d)))
(set (atomcdr (car p)) (car d)) t)
((equal (car p) '+)
(cond ((match-store (cdr p) (cdr d)))
((match-store p (cdr d)))))
((equal (atomcar (car p)) '+)
(cond ((match-store (cdr p) (cdr d))
(set (atomcdr (car p)) (list (car d))) t) ; building begins
((match-store p (cdr d))
(set (atomcdr (car p))
(cons (car d) (eval (atomcdr (car p))))) t)))))
(defun restrict-test (predicates argument)
(prog ()
loop
(cond ((null predicates) (return t))) ; all tests t?
(cond ((funcall (car predicates) argument) ; this test t?
(setq predicates (cdr predicates))
(go loop)) ; then repeat
(t (return nil))))) ; else fail
(defun match-restrict (p d)
(cond
((and (null p) (null d)) t)
((or (null p) (null d)) nil)
; restricted >
((and (not (atom (car p)))
(equal (caar p) 'restrict)
(equal (cadar p) '>)
(restrict-test (cddar p) (car d)))
(match-restrict (cdr p) (cdr d)))
; restricted >var
((and (not (atom (car p)))
(equal (caar p) 'restrict)
(equal (atomcar (cadar p)) '>)
(restrict-test (cddar p) (car d))
(match-restrict (cdr p) (cdr d)))
(set (atomcdr (cadar p)) (car d))
t)
; equality or >
((or (equal (car p) '>)
(equal (car p) (car d)))
(match-restrict (cdr p) (cdr d)))
; >var
((and (atom (car p))
(equal (atomcar (car p)) '>)
(match-restrict (cdr p) (cdr d)))
(set (atomcdr (car p)) (car d))
t)
; +
((equal (car p) '+)
(cond ((match-restrict (cdr p) (cdr d)))
((match-restrict p (cdr d)))))
; +var
((and (atom (car p)) (equal (atomcar (car p)) '+))
(cond ((match-restrict (cdr p) (cdr d))
(set (atomcdr (car p)) (list (car d)))
t)
((match-restrict p (cdr d))
(set (atomcdr (car p))
(cons (car d) (eval (atomcdr (car p)))))
t)))))
;------------------------------------------------------------------------------
; end of f2cl3.l
; f2cl4.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------------
; functions:
; id-logical
; id-logical-and
; id-logical-not
; id-relational
; memberq
;-----------------------------------------------------------------------------
(in-package :user)
(defun memberq (x l) (member x l :test #'eq))
(defun id-logical (l)
(cond ((member 'or l)
`(or ,@(mapcar #'id-logical-and (list-split-multi 'or l))))
(t (id-logical-and l))))
(defun id-logical-and (l)
(cond ((member 'and l)
`(and ,@(mapcar #'id-logical-not (list-split-multi 'and l))))
(t (id-logical-not l))))
(defun id-logical-not (l)
(cond ((equal (car l) 'not)
`(not ,(id-relational (cdr l))))
(t (id-relational l))))
;----------------------------------------------------------------------------
(defun id-relational (l)
(prog (lhs rhs tmplist)
(return
(cond
; true and false
((equal l '(true)) t)
((equal l '(false)) nil)
; bracketed logical expression:
((and (listp (car l)) (null (cdr l)))
(id-logical (car l)))
; logical equivalence
((memberq 'logeqv l)
(setq tmplist (list-split 'logeqv l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(logeqv ,lhs ,rhs))
; logical non-equivalence
((memberq 'logxor l)
(setq tmplist (list-split 'logxor l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(logxor ,lhs ,rhs))
; greater than or equal:
((memberq '|>=| l)
(setq tmplist (list-split '|>=| l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(>= ,lhs ,rhs))
; less than or equal:
((memberq '|<=| l)
(setq tmplist (list-split '|<=| l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(<= ,lhs ,rhs))
; equality:
((memberq 'EQUAL l)
(setq tmplist (list-split-bin 'EQUAL l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(= ,lhs ,rhs))
; not equal:
((memberq '|><| l)
(setq tmplist (list-split '|><| l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(/= ,lhs ,rhs))
; less than:
((memberq '< l)
(setq tmplist (list-split-bin '< l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(< ,lhs ,rhs))
; greater than:
((memberq '> l)
(setq tmplist (list-split-bin '> l))
(setq lhs (id-expression (car tmplist)))
(setq rhs (id-expression (cadr tmplist)))
`(> ,lhs ,rhs))
; bracketed logical:
((and (listp (car l)) (null (cdr l)))
(id-logical (car l)))
(t
(parse-expression l))
))))
;------------------------------------------------------------------------------
; end of f2cl4.l
This diff is collapsed.
; f2cl6.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;Copyright (c) University of Waikato;;;;;
;;;;;;;;;;Hamilton, New Zealand 1992-95 - all rights reserved;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Suite of functions for replacing ".EQ.", ".AND." etc with "=", "AND" etc
;; as a preprocessor for fortran-to-lisp.
;; Numbers such as 6. are replaced with 6.0
;; .6 0.6
;; -.6 -0.6
;; 6.D0 6.0D0
;; etc
;; Also replaces x.xE-x with x.xE~x and x.xE+x with x.xEx so that the lisp reader
;; when set to read FORTRAN can cope.
;; Replaces single quotes (') with double quotes (").
;; Comments are removed
; functions:
; preprocess
; adjust_nrs_and_dots
; parse-logl-op
; replace-str
; parse-number
; write-comment-line
;--------------------------------------------------------------------------
(in-package :user)
(eval-when (compile load eval) (proclaim '(special *verbose* *comments*)))
;--------------------------------------------------------------------------
#+xxxx
(defvar intrinsic_function_names
'(int ifix idint real float sngl dble cmplx ichar char aint dint
anint dnint nint idnint iabs abs dabs cabs mod amod dmod isign sign dsign
idim dim ddim dprod max max0 amax1 dmax1 amax0 amax1 min min0 amini dmini
amini min1 len index lge lgt lle llt aimag 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))
; global stream input for parse-number:
(defvar *inp* nil)
;---------------------------------------------------------------------------
(defun preprocess (file &key (outfile-name "prep.tmp"))
(prog (inport outport line)
(if *verbose* (format t "~&preprocessing begins ...~%"))
(setq inport (infile file)
outport (outfile outfile-name))
loop
(setq line (read-line inport nil 'EOF))
(when (eq line 'EOF)
(close outport)
(close inport)
(return outfile-name))
(setq line (string-upcase (string-right-trim '(#\Space) line)))
(cond
((string= line "") nil) ; we leave out blank lines