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


(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)))
	(print (eval-special-ok expr))))))

;;; 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 HANDLE-ERROR-ON-LAMBDA 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 &rest args)
  (if *error-in-progress?*
      (handle-error-on-lambda *recursive-error-message* string args)
      (let ((*error-in-progress?* T))
	(fresh-line)
	(report-error string args)
	(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)))
	  (fresh-line)
	  (cond ((member char '(#\a #\A))
		 (princ "Resuming read-eval-print loop.")
		 (fresh-line)
		 (throw 'mll-loop))
		((member char '(#\b #\B))
		 (princ *debug-on-lambda-message*)
		 (fresh-line)
		 (handle-error-on-lambda "Handle error on lambda." string args)))))))

(defun report-error (string args)
  (princ ">>>ERROR: ")
  (princ string)
  (fresh-line)
  (let ((i 1))
    (dolist (arg args)
      (princ "Error argument ")
      (princ i)
      (setq i (+ 1 i))
      (princ ": ")
      (princ arg)
      (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)))))

(defun handle-error-on-lambda (reason error-message error-args)
  (nubus-stuff:cause-debugger-trap)
  (hw:nop)
  (hw:read-md)
  nil)