;;; -*- Mode:LISP; Package:LISP-INTERNALS; Readtable:CL; Base:10; Lowercase:T -*- 
;;;
;;;
;;; MINI-LISP-LISTENER.LISP

(defvar *** nil)
(defvar **  nil)
(defvar *   nil)

(defun listener ()
  (fresh-line)
  (fresh-line)
  (princ "K Machine Lisp Listener")
  (fresh-line)
  (princ "Warning:  Running the listener may permanently damage LI:ERROR")
  (fresh-line)
  (setf (symbol-function 'error) (symbol-function 'mll-error))
  (setq *error-in-progress?* NIL)
  (loop
    (catch 'mll-loop
      (fresh-line)
      (princ " ")
      (fresh-line)
      (princ "==> ")
      (let* ((expr (read))
	     (res  (eval-special-ok expr))) ;;Eval expr before resetting history (***, **, and *)
	(print (setq *** **  ;;||| 9/28/88 --wkf
		     **  *
		     *   res))))))

;;; Error handling

(defvar *error-in-progress?* NIL
  "True if we're handling an error, so that recursive error calls
can be dealt with.")

(defvar *recursive-error-message*
	"Recursive error encountered.  Register A1 contains the error
message; register A2 contains the list of arguments to error.")

(defvar *debug-on-lambda-message*
	"Suspending the read-eval-print loop.  You will find the KBUG2
debugger in the BREAK function.  Register A1 will
contain the error message printed above, and register A2 will
contain a list of the error arguments.  Proceeding from this
point will cause the read-eval-print loop to resume at the
point after the error call.  This is usually a bad thing to
try.")

(defun mll-error (string &optional a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15)
  ;;Don't cons up arguments in case any are unboxed (which would crash the K; (illop "Unboxed data.")) --wkf |||
  (if *error-in-progress?*
      (break *recursive-error-message* string a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) ;;Drop an arg.
    (progn (setq a14 *error-in-progress?*
		 *error-in-progress?*  T)
;;      (let ((*error-in-progress?* T))) ;;Don't go over 16 vars.
	(fresh-line)
	(report-error string a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15)
	(fresh-line)
	(princ "Commands available: ")
	(fresh-line)
	(fresh-line)
	(princ "A:  Resume read-eval-print loop")
	(fresh-line)
	(princ "B:  Debug it on the lambda")
	(fresh-line)
	(princ " ")
;;	(let ((char (read-a-character-command)))) ;;Don't go over 16 vars.
	(setq a15 (read-a-character-command))
	  (fresh-line)
	  (cond ((member a15 '(#\a #\A))
		 (princ "Resuming read-eval-print loop.")
		 (fresh-line)
		 (throw 'mll-loop))
		((member a15 '(#\b #\B))
		 (princ *debug-on-lambda-message*)
		 (fresh-line)
		 (break "Handle error on lambda."
			string a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13))) ;;Drop two args. (a14 is lost)
	  (setq *error-in-progress?* a14))))

(defun report-error (string a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15)
  (princ ">>>ERROR: ")
  (princ string)
  (fresh-line)
  #+fleabit-bites(let ((i 1))
		   (dolist (arg args)
		     (princ "Error argument ")
		     (princ i)
		     (setq i (+ 1 i))
		     (princ ": ")
		     (write arg)		;make ERROR args print with package prefixes --pfc
		     (fresh-line)))
  (when a1
    (princ "Error argument 1:") (write a1) (fresh-line)
    (when a2
      (princ "Error argument 2:") (write a2) (fresh-line)
      (when a3
	(princ "Error argument 3:") (write a3) (fresh-line)
	(when a4
	  (princ "Error argument 4:") (write a4) (fresh-line)
	  (when a5
	    (princ "Error argument 5:") (write a5) (fresh-line)
	    (when a6
	      (princ "Error argument 6:") (write a6) (fresh-line)
	      (when a7
		(princ "Error argument 7:") (write a7) (fresh-line)
		(when a8
		  (princ "Error argument 8:") (write a8) (fresh-line)
		  (when a9
		    (princ "Error argument 9:") (write a9) (fresh-line)
		    (when a10
		      (princ "Error argument 10:") (write a10) (fresh-line)
		      (when a11
			(princ "Error argument 11:") (write a11) (fresh-line)
			(when a12
			  (princ "Error argument 12:") (write a12) (fresh-line)
			  (when a13
			    (princ "Error argument 13:") (write a13) (fresh-line)
			    (when a14
			      (princ "Error argument 14:") (write a14) (fresh-line)
			      (when a15
				(princ "Error argument 15:") (write a15) (fresh-line)))))))))))))))))

(defun read-a-character-command ()
  (loop
    (let ((char (read-char)))
      (when (member char '(#\a #\A #\b #\B))
	(return-from read-a-character-command char)))))