;;;; Unlambda interpreter with tracing capabilities

(defun evaluate (expr &optional (stm *trace-output*))
  (do (res (tracing '(nil)) (curc nil) (stk `((ev ,@expr))))
      ((null stk) res)
    (setf
     (values stk res)
     (case (caar stk)
       ((ev)
	(when (car tracing)
	  (format stm "~&(~D) EVAL " (length stk))
	  (dump (cdar stk) stm)
	  (terpri stm))
	(if (consp (cadar stk))
	    `((ev ,@(caadar stk)) (ev1 ,@(cdadar stk)) ,@(cdr stk))
	  (values (cdr stk) (cdar stk))))
       ((ev1)
	(case (car res)
	  ((d) (values (cdr stk) `(d1 ,@(cdar stk))))
	  ((t) (unless (car tracing) (format stm "~&START TRACING~%"))
	       (push 't tracing)
	       `((ev ,@(cdar stk)) (tr) ,@(cdr stk)))
	  ((n) (push nil tracing)
	       `((ev ,@(cdar stk)) (tr) ,@(cdr stk)))
	  (t   `((ev ,@(cdar stk)) (ap ,@res) ,@(cdr stk)))))
       ((tr) (if (and (car tracing) (not (cadr tracing)))
		 (format stm "~&STOP TRACING~%"))
	     (pop tracing)
	     (values (cdr stk) res))
       ((ap)
	(let ((a (cdar stk)) (cnt (cdr stk)))
	  (when (car tracing)
	    (format stm "~&(~D) APPLY " (length stk))
	    (dump a stm)
	    (write-string " TO " stm)
	    (dump res stm)
	    (terpri stm))
	  (ecase (car a)
	    ((k)  (values cnt `(k1 ,@res)))
	    ((k1) (values cnt (cdr a)))
	    ((s)  (values cnt `(s1 ,@res)))
	    ((s1) (values cnt `(s2 ,(cdr a) ,@res)))
	    ((s2) `((ev (((,(cadr a) ,@res)) (,(cddr a) ,@res))) ,@cnt))
	    ((i)  (values cnt res))
	    ((v)  (values cnt a))
	    ((e)  (values nil res))
	    ((c)  `((ev (,res c1 ,cnt ,@tracing)) ,@cnt))
	    ((c1) (setq tracing (cddr a)) (values (cadr a) res))
	    ((d1) `((ev (,(cdr a) ,@res)) ,@cnt))
	    ((at) (if (car tracing) (format stm "~&INPUT: "))
	          (setq curc (read-char *standard-input* nil))
		  (if (car tracing)
		      (format stm (if curc "<- ~C~%" "[EOF]~%") curc))
	          `((ev (,res ,(if curc 'i 'v))) ,@cnt))
	    ((dt) (if (car tracing)
		      (format stm "~&OUTPUT ~C~%" (cdr a))
		    (write-char (cdr a)))
	          (values cnt res))
	    ((qu) `((ev (,res ,(if (eql curc (cdr a)) 'i 'v))) ,@cnt))
	    ((pi) `((ev (,res ,@(if curc `(dt ,@curc) '(v)))) ,@cnt))
	    ((sl) `((ev (,res ,@(if curc `(qu ,@curc) '(v)))) ,@cnt)))))))
    (when (and (car tracing) res)
      (format stm "~&-> ")
      (dump res stm)
      (terpri stm))))

(defun parse (stm)
  (ecase (char-downcase
	  (loop (let ((c (read-char stm)))
		  (if (eql c #\#) (read-line stm)
		    (or (member c '(#\Space #\Newline #\Tab #\Return))
			(return c))))))
    ((#\`) `((,(parse stm) ,@(parse stm))))
    ((#\k) '(k))
    ((#\s) '(s))
    ((#\i) '(i))
    ((#\v) '(v))
    ((#\c) '(c))
    ((#\d) '(d))
    ((#\e) '(e))
    ((#\@) '(at))
    ((#\|) '(pi))
    ((#\/) '(sl))
    ((#\r) '(dt . #\Newline))
    ((#\.) `(dt ,@(read-char stm)))
    ((#\?) `(qu ,@(read-char stm)))
    ((#\t) '(t))
    ((#\n) '(n))))

(defun dump (expr &optional (stm *trace-output*))
  (case (car expr)
    ((s)  (write-char #\s stm))
    ((k)  (write-char #\k stm))
    ((i)  (write-char #\i stm))
    ((v)  (write-char #\v stm))
    ((c)  (write-char #\c stm))
    ((d)  (write-char #\d stm))
    ((e)  (write-char #\e stm))
    ((at) (write-char #\@ stm))
    ((pi) (write-char #\| stm))
    ((sl) (write-char #\/ stm))
    ((dt) (if (eql (cdr expr) #\Newline)
	      (write-char #\r stm)
	    (progn (write-char #\. stm) (write-char (cdr expr) stm))))
    ((qu) (write-char #\? stm) (write-char (cdr expr) stm))
    ((s1) (write-string " `s" stm) (dump (cdr expr) stm))
    ((s2) (write-string " ``s" stm) (dump (cadr expr) stm) (dump (cddr expr) stm))
    ((k1) (write-string " `k" stm) (dump (cdr expr) stm))
    ((d1) (write-string " `d" stm) (dump (cdr expr) stm))
    ((c1) (dump-cont (cadr expr) stm))
    ((t)  (write-char #\t stm))
    ((n)  (write-char #\n stm))
    (t    (if (not (consp (car expr)))
	      (dump-bug expr stm)
	    (progn
	      (write-char #\` stm) (dump (caar expr) stm) (dump (cdar expr) stm))))))

(defun dump-cont (stk &optional (stm *trace-output*))
  (write-string "[cont" stm)
  (dolist (x stk)
    (case (car x)
      ((ev)  (write-string ": EVAL " stm) (dump (cdr x) stm))
      ((ev1) (write-string ": EVAL `<?>" stm) (dump (cdr x) stm))
      ((ap)  (write-string ": APPLY " stm) (dump (cdr x) stm))
             ; (write-string " TO <?>" stm)
      ((tr)  (write-string ": POPTRACE" stm))
      (t     (dump-bug (car x) stm))))
  (write-char #\] stm))

(defun dump-bug (expr stm)
  (write-string "<BUG " stm)
  (princ expr stm)
  (write-char #\> stm))


;; *ARGS* is a CLISP extension, it is bound to the list of cmd-line arguments
(handler-case
 (evaluate
  (if (and (boundp '*args*) *args*)
      (with-open-file (pgm (car *args*)) (parse pgm))
    (prog1 (parse *standard-input*) (read-line *standard-input* nil))))
 (end-of-file () (write-line "Unexpected end of file." *error-output*))
 (type-error (var)
	     (format *error-output*
		     "Unknown function `~C'.~%" (type-error-datum var)))
 (storage-condition () (format  *error-output* "~&Out of memory.~%")))