#|
Yee Hsu
Dr. V. Cavalli-Sforza
Csc 600 - Programming Languages
Nov 18, 2001

Assignment #2:  Forsim - Fortran Interpreter

USAGE:

libra% clisp
> (load "hw2.lsp")
> (forsim "program.for")
> (quit)

|# 

;; Initialize variables
(setq ret NIL)
(setq code NIL)
(setq symtab NIL)

;; Load fortran file (*.for) and start the interpreter
(defun forsim (fname)
   (setq code (make-list-from-sexpr-file fname))
   (setq temp code)
   (setq linenum 0)
        (loop
            (setq token (car temp))
            (setq temp  (cdr temp))

            (cond
                ((equal token 'PROGRAM)         (parseprog))
                ((equal token 'SUBPROGRAM)      (parsesubp))
                ((equal token 'CALL)            (parsecall))
                ((equal token 'READ)            (parser))
                ((equal token 'WRITE)           (parsew))
                ((equal token 'WRITELN)         (parsewl))
                ((equal token 'INTEGER)         (parseint))
                ((equal token 'IF)              (parseif))
                ((equal token 'DO)              (parsedo))
                ((equal token 'GOTO)            (parsego))
                ((equal token 'CONTINUE)        (parsecont))
                ((equal token '.EQ.)            (parseeq))
                ((equal token '.NEQ.)           (parseneq))
                ((equal token '.LT.)            (parselt))
                ((equal token '.LE.)            (parsele))
                ((equal token '.GT.)            (parsegt))
                ((equal token '.GE.)            (parsege))
                ((equal token 'DIMENSION)       (parsed))
                ((equal token 'END)             (parsee)) )) )


;;; Read a file of s-expressions and return the whole thing as a list
;;; in the same order that it was read.
(defun make-list-from-sexpr-file (fname)
   (let* ((header (list 'header))
        (lastitem header))
     (format T "Opening file ~s~%" fname)
     (dofile (item fname)
        (setf (cdr lastitem) (list item))
        (setq lastitem (cdr lastitem)))
     (cdr header) ))

;;; Call syntax is just like for dolist:
;;; (dofile (x "filename" 'DONE) s-expr s-expr ... s-expr)
(defmacro dofile ((var filename &optional return-form) &body body)
  "Opens the specified file for input, reads successive forms 
   from the file, setting the specified variable <var> to
   each form.  When end of file is reached, the value of <return-form>
   is returned."
  ;; After an idea by Eric Nyberg.
  (let ((eof (gensym "EOF"))
        (stream (gensym "STREAM")))
    `(with-open-file (,stream ,filename :direction :input)
       (do ((,var (read ,stream nil ',eof)
            (read ,stream nil ',eof)))
           ((eq ,var ',eof)
            ,return-form)
         ,@body))))


;; Test if symbol is an opcode
(defun isopcode (s)
    (setq ret NIL)
    (dolist (i '(+ - * /) ret)
        (if (equal i s)
            (setq ret T) () ))) 


;; Evaluate [+,-,*,/]: opr1 [opcode] opr2
(defun compute (opcode opr1 opr2)
    (cond
        ((equal opcode '*) (setq ret (* opr1 opr2)))
        ((equal opcode '+) (setq ret (+ opr1 opr2)))
        ((equal opcode '/) (setq ret (/ opr1 opr2)))
        ((equal opcode '-) (setq ret (- opr1 opr2)))
        (t (print "Error: invalid operator")) ))


;; Test if symbol is already in the symbol table
(defun issymbol(symtab symnum subnum symkey)
    (setq ret nil)    
    (dotimes (i symnum ret)
        (if (equal (aref symtab subnum i 0) symkey)
            (setq ret T) () )))


;; Add a symbol in the symble table
(defun addsym (s value id)
    (cond
    ((null s)
        (list id value))
    ((eq (car s) id)
        (append (list (car s) value) (cddr s)))
    ((not (eq (car s) id))
        (append (list (car s) (cadr s)) (addsym (cddr s) value id))) ))


;; Delete a symbol in the symbol table
(defun delsym (s key)
    (cond ((eq (car s) key)
        (cddr s))
    ((not (eq (car s) key))
        (append (list (car s) (cadr s)) (delsym (cddr s) key))) ))


;; Make a list if it is already not a list
(defun mklist (x)
  (if (listp x)
    x
    (list x)))


;; Get an entry from the symbol table
(defun getentry (entry s)
    (if (eq (car s) entry)
        (list entry (cadr s))
    (getentry entry (cddr s)) ))


#|
;; Make a record entry
(defun record-entry (name rec)
  (incf (getf kind 0))
  (let ((entry (get-entry name)))
    (if (numberp rec)
    (setf (entry-page entry) rec)
    (push (entry) (rec))
        (entry-defs entry)))
|#

;; Return the frist atom of a list
(defun first-atom (L)
    (if (atom L)
        L
        (first-atom (first L))))

;; Apply L to list and append
(defun mappend (L &rest lists)
  (reduce #'append (apply #'mapcar L lists) :from-end T))


;; test list starts with element
(defun starts-with (list element)
  (and (consp list)
    (eq (first list) element)))


;; convert lable table to list
(defun lable-table->list (table)
  (maphash #'cons table))

;; Print label table
(defun lable-print (l &optional (stream t)) 
  (maphash #'(lambda (key val)
    (format stream "~&~A:~10T ~A" key val) ) l) l)


;; A list as a queue data structure
(defstruct Queue
  (key #'data)
  (last nil)
  (elements nil))

;; Queue constructor
(defun make-empty-queue ()
    (nil))

;; Test if queue is an empty queue
(defun queue-empty (q)
  (= (length (elements q)) 0))

;; Remove the first element of the queue
(defun dequeue (q)
  (elt (elements q) 0))

;; Add an element into the front of the queue
(defun enqueue-at-front (q items)
  (setf (elements q)
    (nconc items (elements q))))

;; Add an element at the end of the queue
(defun enqueue (q items)
  (cond ((null items) nil)
    ((or (null (last q)) (null (elements q)))
     (setf (last q) (last items)
           (elements q) (nconc (elements q) items)))
    (t (setf (cdr (last q)) items
         (last q) (last items)))))

;; Count the elements in the queue
(defun count-elements (q)
  (if (endp q)
    0
    (+ 1 (count-elements (rest q))) ))

;; Count the atoms in the queue
(defun count-atoms (q)
  (cond ((null q) 0)
    ((atom q) 1)
    (T (+ (count-atoms (first q))
          (count-atoms (rest q)) ))) )

;; Parse the program statement
(defun parseprog ()
    (setq pname (car temp))
    (setq temp (cdr temp))
    (incf linenum))

;; Parse the subprogram statement
(defun parsesubp ()
    (setq psname (car temp))
    (setq temp (cdr temp))
    (setq linenum 0)
)

;; Parse the call statement
(defun parsecall ()
    (setq subpname (car temp))
    (setq temp (cdr temp))
    (setq param (car temp))
    (setq temp (cdr temp))
    (incf linenum))

;; Prase the read statement
(defun parser ()
    (setq input (car temp))
    (setq temp (cdr temp))
    (print input)
    (incf linenum)
)

;; Parse the write statement
(defun parsew ()
    (setq output (car temp))
    (setq temp (cdr temp))
    (print output)
    (incf linenum)
)

;; Parse the writeln statement
(defun parsewl ()
    (parsew)
    (print ())
)

;; Parse the int statement
(defun parseint ()
    (setq ident (car temp))
    (setq temp (cdr temp))
    (setq value (car temp))
    (setq temp (cdr temp))
    (incf linenum)
    (addsym symtab 'value 'ident) )

;; Parse the if statement
(defun parseif ()
    (setq op1 (car temp))
    (setq temp (cdr temp))
    (setq op2 (car temp))
    (setq temp (cdr temp))
    (if (eq op1 op2)
    T
    ())
    (incf linenum) )

;; Parse the do statement
(defun parsedo ()
    (setq dotok (car temp))
    (setq temp (cdr temp))
    (incf linenum)
)

;; Parse the goto satement
(defun parsego ()
    (setq label (car temp))
    (setq temp (cdr temp))
    (incf linenum))

;; Parse the continue statement
(defun parsecont ()
    (incf linenum))


;; Test equal
(defun .eq. ()
    (setq op1 (car temp))
    (setq temp (cdr temp))
    (setq op2 (car temp))
    (setq temp (cdr temp))
    (if (eq op1 op2)
    T
    ())
    (incf linenum)
)

;; Test not equal
(defun .neq. ()
    (setq op1 (car temp))
    (setq temp (cdr temp))
    (setq op2 (car temp))
    (setq temp (cdr temp))
    (if (not (eq op1 op2))
    T
    ())
    (incf linenum)
)

;; Parse the dimension statement
(defun parsed ()
    (setq dim (car temp))
    (setq temp (cdr temp))
    (parseint)
    (parseint)
    (incf linenum))

;; Parse the end statement
(defun parsee ()
    (setq linenum 0) ())