;;;from phelps@palm.cs.berkeley.edu wed dec 16 16:37:17 1992
;;; $header: /home/yew/yew5/users/phelps/cs/283/cgol/rcs/parser.cl,v 1.3 1992/12/03 20:34:18 phelps exp phelps $
;;;
;;; cgol.cl by v.a. pratt
;;; largely rewritten, in common lisp, by t.a. phelps, november-december 1992
;;; university of california at berkeley
;;;

;;; gosh, this file is much smaller than before

(defvar token nil)
;;(defvar ret-nud nil "the instance variable of a recycled closure")
;;(defun ret-nud () ret-nud)
(defvar stringnud nil)	; points to ret-nud function if non-null
(defun ret-tok () token)

(defvar cibase 10.)
(defvar cgolerr nil "controls throws for eof condition")
(defvar parser_debug nil "if t show stream of tokens")
(defvar scripting nil "if t show stream of input tokens")
(defvar ctoken-table nil)	; badly done
(defvar cgol-rt-stack nil "holds stack of readtables")
(defparameter syntax-needed nil)	;12/6/02 RJF

(defvar fun 'top-level)	; for error handling
;;(defvar silence -1)	; ???


;;;
;;; parser - returns tokens
;;;

(defvar *lisp-readtable* (copy-readtable))
(defvar *cgol-readtable* (copy-readtable))

(defun lisp-read (&optional (stream *standard-input*))
  (let ((*readtable* *lisp-readtable*))
    (read stream)))

(defun cread (&optional (stream *standard-input*))
  (let ((*readtable* *cgol-readtable*))
    (read stream)))

(defun read-comment (stream character)
  (declare (ignore character))
  (let ((*readtable* *lisp-readtable*))
	(read-delimited-list #\% stream)
	(cread)))


(defun initialize-multi-character-token-table (string)
  (setq ctoken-table string)
  (every #'(lambda (c) (set-macro-character c #'smash-token nil *cgol-readtable*)) string))

(defun smash-token (stream c)
  (intern (coerce
	   (cfollow-tail c stream (subseq ctoken-table (1+ (position c ctoken-table))))
	   'string)))

(defun cfollow-tail (c stream table)
  ;; this way of recognizing tokens is taken from the original cgol,
  ;; is fast and easy and passes all tokens which are subtokens
  ;; of explicitly defined tokens.
  ;; [but it will pass erroneous multi-character tokens.  --tap]
  (let* (;;(c2 (char-upcase (peek-char nil stream)))
	 (c2 (peek-char nil stream)) ;;12/6/02 RJF
	 (posn (position c2 table)))
    (cons c
	  (if posn
	      (progn (read-char stream)
		     (cfollow-tail c2 stream (subseq table (1+ posn))))))))

(let ((*readtable* *cgol-readtable*))
  ; unchanged are: string, numbers, whitespace 
  (set-macro-character #\% #'read-comment nil)
  (set-macro-character #\! #'(lambda (s c) (declare (ignore c))
				     (lisp-read s)) nil)
  (set-syntax-from-char #\? #\\)	; escape character is '?'
  ; semicolon is now statement terminator--changed by initialize-multi-character-token-table
  )

(defun cgoltoken ()
  (cread))


;;--------------------------------------------------
;; yuckiness follows

;;; *** user entry point #1 ***
;;; read a cgol expression,
;;; then call parse to convert it to common lisp

;; replace most of this with (parse -1)
;; add error handling later

;;; rjf ??
(defvar eofm nil)

(defun cgolread (&rest read-args)
  (let (stream eofm)	;norvig, in his ghwb impression, says &aux is "bad! bad!"
    ; dispatch on first character, save rest in eofm
  (setq stream (or (car read-args) *standard-input*)
	eofm (cdr read-args))
    (catch 'cgolerr (toplevel-parse stream))))

(defun toplevel-parse (*standard-input*
		       &aux
;;		       ;; state variables.
;;		       (cgolerr t) token stringnud ret-nud
		       ;;		       (fun 'top-level)
		       parser-debug
;; may throw the eof marker here.
		       )
  (format t "~%cgol(1)> ")
  (let ((expr 'do-at-least-once) (show-syntax t))
    (setq cgolerr nil)
    (setq parser-debug nil)
    (setq scripting nil)
    (do ((ctr 2 (+ ctr 1)) (bozo (advance) (advance))) ((not expr) 'ok)
      (declare(ignore bozo))
      (setq expr (parse -1))
      (cond ((eq expr 'eval) (setq syntax-needed (not syntax-needed)))
	    ((eq expr 'show) (setq show-syntax (not show-syntax)))
	    ((eq expr 'parser_debug) (setq parser-debug (not parser-debug)))
	    ((eq expr 'scripting) (setq scripting (not scripting)))
	    ((eq expr 'quit) (setq expr nil))
	    (t (if show-syntax (format t "~%  lisp> ~a " expr))
	       (if syntax-needed (format t "~%  value> ~a" (eval expr)))))
      (format t "~%cgol(~d)> " ctr)
      )))


;;  (cond ((eq (advance) 'escape)	;should be escape character
;;	 ;; kludge for old cgol source files.
;;	 ''escape)
;;	(t
;;	 (setq cgolerr nil)
;;	 (parse -1)))

(defun cgolerr (message level fatalp)
  (declare (ignore level)) ;; someday, do something more sophisticated
  (cond ((and fatalp cgolerr)
	 (throw 'cgolerr eofm))
	(t
	 (error "error: ~s in ~s" message fun))))



;; the problem of invoking cgol over a whole stream is correctly solved by
;; pushing and popping a stack of read methods for a stream.
;; however, maclisp and the lisp machine provide special variables read and readtable
;; for this.


(defun cgol-enter (ignore-it)
  (declare (ignore ignore-it))
  (push *readtable* cgol-rt-stack))

(defun cgol-exit ()
  (if (consp cgol-rt-stack)
      (setf *readtable* (pop cgol-rt-stack))))

(defun cgol () (cgolread))
(defun cg () (cgolread))  ;shorthand