#!/usr/local/calypso
;
; parser - test a parse table
;


;
; data abstraction
;
; a non terminal is a symbol bound to a list of lists
; a terminal is a symbol not bound to a list
; an action is a string
;

(defun non-terminalp (item)
  (and (symbolp item) 
       (boundp item)
       (listp (eval item))
       )
  )

(defun terminalp (item)
  (or (null item)
      (and (symbolp item)
	   (not (non-terminalp item))
	   )
      )
  )

(defun actionp (item)
  (stringp item)
  )

(defun null-production (p)
  (if (null p)
      t
   elseif (stringp (car p))
      (null-production (cdr p))
   else
      nil
      )
  )

(defun start-symbolp (item) (equal item start-symbol))

(defun parser (parse-table start-symbol end-token)
  (let ((stack (list start-symbol end-token))
	(input-token (lex))
	(table-entry)
	(tos)
	)
    (while stack

	   (patom "stack is ")
	   (print stack)

	   (setq tos (car stack)) (setq stack (cdr stack))
	   (if (non-terminalp tos)
	       (setq table-entry (dictionary-lookup parse-table
 	       					    (list input-token tos))
		     )
	       (if (null table-entry)
	       	   (error (strcat "parser: error on " (sprint input-token)))
	       	   )

	       (patom " pushing production ") (print (cadr table-entry)) (terpr)

	       (cond ((cadr table-entry)
	       	      (setq stack (conc (cadr table-entry) stack))
		      )
		     )
	    elseif (actionp tos)
	       (patom "token is ") (print input-token)
	       (patom " performing action ") (print tos) (terpr)
	       (action tos input-token)
	    elseif (terminalp tos)
	       (if (= tos input-token)

		   (patom " matching token ") (print tos) (terpr)

		   (if (not (= tos end-token))
		       (setq input-token (lex))
		       )
		else
		   (error (strcat "parser error on " (sprint input-token)))
		   )
	       )
	   )
    )
  )

(defun lex ()
  (let ((char (getchar)))
    (cond ((or (= char ~ )
	       (= char ~\t )
	       )
	   (lex)
	   )
	  ((or (= char nil)
	       (= char -1)
	       )
	   (symbol "$" parse-dictionary)
	   )
	  (t
	   (symbol (scons char nil) parse-dictionary)
	   )
    	  )
    )
  )
	       
(setq value-stack nil)

(defun pop-stack ()
  (let ((t (car value-stack)))
    (setq value-stack (cdr value-stack))
    t)
  )

(defun push-stack (t)
  (setq value-stack (cons t value-stack))
  t
  )

(setq value-temp 0)

(defun action (name value)
  (let ((t1) (t2))
    (cond ((= "ADD" name)
	   (push-stack (+ (pop-stack) (pop-stack)))
	   )
	  ((= "SUBTRACT" name)
	   (setq t1 (pop-stack))
	   (setq t2 (pop-stack))
	   (push-stack (- t2 t1))
	   )
	  ((= "MULTIPLY" name)
	   (push-stack (* (pop-stack) (pop-stack)))
	   )
	  ((= "DIVIDE" name)
	   (setq t1 (pop-stack))
	   (setq t2 (pop-stack))
	   (push-stack (/ t2 t1))
	   )
	  ((= "PUSH" name)
	   (push-stack value-temp)
	   )
	  ((= "NEGATE" name)
	   (push-stack (- 0 (pop-stack)))
	   )
	  ((= "CLEAR" name)
	   (setq value-temp 0)
	   )
	  ((= "ADD-DIGIT" name)
	   (setq value-temp (+ (* value-temp 10)
			       (- (scar (get-name value)) ~0)
			       )
	       	 )
	   )
	  ((= "PRINT" name)
	   (print (pop-stack)) (terpr)
	   )
	  )
    )
  )

(defun init ()
  (setq parse-table (new-dictionary))
  (setq parse-dictionary (new-dictionary))
  (setq end-token (symbol "$" parse-dictionary))
  )

(defun cadaar (l) (car (cdr (car (car l)))))

(defun bind-to-lists (atoms)
  (cond (atoms (set (car atoms) '(foo)) (bind-to-lists (cdr atoms)))
	(t nil)
	)
  )

(defun put-lists-into-parse-table (lists parse-table)
  (cond (lists
	 (dictionary-insert parse-table (caar lists) (car lists))
	 (put-lists-into-parse-table (cdr lists) parse-table)
	 )
	(t nil)
	)
  )

(defun process-file (file-in)
  (init)
  (setq terminals (fread-dictionary file-in parse-dictionary))
  (setq non-terminals (fread-dictionary file-in parse-dictionary))
  (bind-to-lists non-terminals)
  (setq table (fread-dictionary file-in parse-dictionary))
  (setq start-symbol (cadaar table))
  (put-lists-into-parse-table table parse-table)
  (parser parse-table (cadaar table) end-token)
  )      

(defun main-parser ()
  (setq file-in stdin)
  (if argv
      (setq file-in (fopen (car argv) 'r))
      (if (null file-in)
	  (error (strcat "parser: can't open " (sprint (car argv))))
	  )
      )
  (process-file file-in)
  (fclose file-in)
  )

(main-parser)
