;;;; Replicate much of the ACL toplevel functionality in SBCL. Mostly
;;;; this is portable code, but fundamentally it all hangs from a few
;;;; SBCL-specific hooks like SB-INT:*REPL-READ-FUN* and
;;;; SB-INT:*REPL-PROMPT-FUN*.
;;;;
;;;; The documentation, which may or may not apply in its entirety at
;;;; any given time, for this functionality is on the ACL website:
;;;;   <http://www.franz.com/support/documentation/6.2/doc/top-level.htm>.

(cl:defpackage :sb-aclrepl
  (:use :cl :sb-ext)
  (:export #:*prompt* #:*exit-on-eof* #:*max-history*
	   #:*use-short-package-name* #:*command-char*
	   #:alias))

(cl:in-package :sb-aclrepl)

(defstruct user-cmd
  (input nil) ; input, maybe a string or form
  (func nil)  ; cmd func entered, overloaded
              ; (:eof :null-cmd :cmd-error :history-error)
  (args nil)  ; args for cmd func
  (hnum nil)) ; history number

(defstruct break-data
  ;; numeric break level
  level
  ;; inspect data for a break level
  inspect
  ;; T when break initiated by an inspect
  inspect-initiated
  ;; restarts list for a break level
  restarts 
  ;; T if break level is a continuable break
  continuable) 

;;; cmd table entry
(defstruct cmd-table-entry
  (name nil) ; name of command
  (func nil) ; function handler
  (desc nil) ; short description
  (parsing nil) ; (:string :case-sensitive nil)
  (group nil) ; command group (:cmd or :alias)
  (abbr-len 0)) ; abbreviation length
  
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *default-prompt* "~:[~2*~;[~:*~D~:[~;i~]~:[~;c~]] ~]~A(~D): "
    "The default prompt."))
(defparameter *prompt* #.*default-prompt*
  "The current prompt string or formatter function.")
(defparameter *use-short-package-name* t
  "when T, use the shortnest package nickname in a prompt")
(defparameter *dir-stack* nil
  "The top-level directory stack")
(defparameter *command-char* #\:
  "Prefix character for a top-level command")
(defvar *max-history* 24
  "Maximum number of history commands to remember")
(defvar *exit-on-eof* t
  "If T, then exit when the EOF character is entered.")
(defparameter *history* nil
  "History list")
(defparameter *cmd-number* 1
  "Number of the next command")
(defparameter *repl-output* nil
  "The output stream for the repl")
(defparameter *repl-input* nil
  "The input stream for the repl")
(defparameter *break-stack*  (list (make-break-data :level 0))
  "A stack of break data stored as a list of break-level structs")

(declaim (type list *history*))

(defvar *eof-marker* :eof)
(defvar *eof-cmd* (make-user-cmd :func :eof))
(defvar *null-cmd* (make-user-cmd :func :null-cmd))

(defparameter *cmd-table-hash*
  (make-hash-table :size 30 :test #'equal))

;; Set up binding for multithreading

(let ((*prompt* #.*default-prompt*)
      (*use-short-package-name* t)
      (*dir-stack* nil)
      (*command-char* #\:)
      (*max-history* 24)
      (*exit-on-eof* t)
      (*history* nil)
      (*cmd-number* 1)
      (*repl-output* nil)
      (*repl-input* nil)
      (*break-stack* (list (make-break-data :level 0)))
      )
      
(defun prompt-package-name ()
  (if *use-short-package-name*
      (car (sort (append
		  (package-nicknames cl:*package*)
		  (list (package-name cl:*package*)))
		 (lambda (a b) (< (length a) (length b)))))
      (package-name cl:*package*)))

(defun read-cmd (input-stream)
  ;; Reads a command from the user and returns a user-cmd object
  (flet ((parse-args (parsing args-string)
	   (case parsing
	     (:string
	      (if (zerop (length args-string))
		  nil
		  (list args-string)))
 	     (t
	      (let ((string-stream (make-string-input-stream args-string))
		    (eof (cons nil *eof-marker*))) ;new cons for eq uniqueness
		(loop as arg = (read string-stream nil eof)
		      until (eq arg eof)
		      collect arg))))))
    (let ((next-char (peek-char-non-whitespace input-stream)))
      (cond
	((eql next-char *command-char*)
	 (let* ((line (string-trim-whitespace (read-line input-stream)))
		(first-space-pos (position #\space line))
		(cmd-string (subseq line 1 first-space-pos))
		(cmd-args-string
		 (if first-space-pos
		     (string-trim-whitespace (subseq line first-space-pos))
		     "")))
	   (declare (string line))
	   (if (numberp (read-from-string cmd-string))
	       (let ((cmd (get-history (read-from-string cmd-string))))
		 (if (eq cmd *null-cmd*)
		     (make-user-cmd :func :history-error
				    :input (read-from-string cmd-string))
		     (make-user-cmd :func (user-cmd-func cmd)
				    :input (user-cmd-input cmd)
				    :args (user-cmd-args cmd)
				    :hnum *cmd-number*)))
	       (let ((cmd-entry (find-cmd cmd-string)))
		 (if cmd-entry
		     (make-user-cmd :func (cmd-table-entry-func cmd-entry)
				    :input line
				    :args (parse-args
					   (cmd-table-entry-parsing cmd-entry)
					   cmd-args-string)
				    :hnum *cmd-number*)
		     (make-user-cmd :func :cmd-error
				    :input cmd-string)
		     )))))
	((eql next-char #\newline)
	 (read-char input-stream)
	 *null-cmd*)
      (t
       (let* ((eof (cons nil *eof-marker*))
	      (form (read input-stream nil eof)))
	 (if (eq form eof)
	     *eof-cmd*
	     (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))

(defun make-cte (name-param func desc parsing group abbr-len)
  (let ((name (etypecase name-param
		(string
		 name-param)
		(symbol
		 (string-downcase (write-to-string name-param))))))
    (make-cmd-table-entry :name name :func func :desc desc
			  :parsing parsing :group group
			  :abbr-len (if abbr-len
					abbr-len
					(length name)))))

(defun %add-entry (cmd &optional abbr-len)
  (let* ((name (cmd-table-entry-name cmd))
	 (alen (if abbr-len
		   abbr-len
		   (length name))))
    (dotimes (i (length name))
      (when (>= i (1- alen))
	(setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
	      cmd)))))

(defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
  (%add-entry
   (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len)
   abbr-len))
   
(defun find-cmd (cmdstr)
  (gethash (string-downcase cmdstr) *cmd-table-hash*))

(defun user-cmd= (c1 c2)
  "Returns T if two user commands are equal"
  (and (eq (user-cmd-func c1) (user-cmd-func c2))
       (equal (user-cmd-args c1) (user-cmd-args c2))
       (equal (user-cmd-input c1) (user-cmd-input c2))))

(defun add-to-history (cmd)
  (unless (and *history* (user-cmd= cmd (car *history*)))
    (when (>= (length *history*) *max-history*)
      (setq *history* (nbutlast *history* (+ (length *history*) *max-history* 1))))
    (push cmd *history*)
    (incf *cmd-number*)))

(defun get-history (n)
  (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
    (if cmd
	cmd
	*null-cmd*)))

(defun get-cmd-doc-list (&optional (group :cmd))
  "Return list of all commands"
  (let ((cmds '()))
    (maphash (lambda (k v)
	       (when (and
		      (= (length k) (length (cmd-table-entry-name v)))
		      (eq (cmd-table-entry-group v) group))
		 (push (list k
			     (if (= (cmd-table-entry-abbr-len v)
				    (length k))
				  ""
				  (subseq k 0 (cmd-table-entry-abbr-len v)))
			     (cmd-table-entry-desc v)) cmds)))
	     *cmd-table-hash*)
    (sort cmds #'string-lessp :key #'car)))

(defun cd-cmd (&optional string-dir)
  (cond
    ((or (zerop (length string-dir))
	 (string= string-dir "~"))
     (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
    (t
     (let ((new (truename string-dir)))
       (when (pathnamep new)
	 (setf cl:*default-pathname-defaults* new)))))
  (format *repl-output* "~A~%" (namestring cl:*default-pathname-defaults*))
  (values))

(defun pwd-cmd ()
  (format *repl-output* "Lisp's current working directory is ~s.~%"
	  (namestring cl:*default-pathname-defaults*))
  (values))

(defun trace-cmd (&rest args)
  (if args
      (format *repl-output* "~A~%" (eval (sb-debug::expand-trace args)))
      (format *repl-output* "~A~%" (sb-debug::%list-traced-funs)))
  (values))

(defun untrace-cmd (&rest args)
  (if args
      (format *repl-output* "~A~%"
	      (eval
	       (sb-int:collect ((res))
		(let ((current args))
		  (loop
		   (unless current (return))
		   (let ((name (pop current)))
		     (res (if (eq name :function)
			      `(sb-debug::untrace-1 ,(pop current))
			      `(sb-debug::untrace-1 ',name))))))
		`(progn ,@(res) t))))
      (format *repl-output* "~A~%" (eval (sb-debug::untrace-all))))
  (values))

#+sb-thread
(defun thread-pids ()
  "Return a list of the pids for all threads"
  (let ((offset (* 4 sb-vm::thread-pid-slot)))
    (sb-thread::mapcar-threads
     #'(lambda (sap) (sb-sys:sap-ref-32 sap offset)))))

#+sb-thread
(defun other-thread-pids ()
  "Returns a list of pids for all threads except the current process"
  (delete (sb-thread:current-thread-id) (thread-pids) :test #'eql))

(defun exit-cmd (&optional (status 0))
  #+sb-thread
  (let ((other-pids (other-thread-pids)))
    (when other-pids
      (format *repl-output* "There exists the following processes~%")
      (format *repl-output* "~{~5d~%~}" other-pids)
      (format *repl-output* "Do you want to exit lisp anyway [n]? ")
      (force-output *repl-output*)
      (let ((input (string-trim-whitespace (read-line *repl-input*))))
	(if (and (plusp (length input))
		 (or (char= #\y (char input 0))
		     (char= #\Y (char input 0))))
	    ;; loop in case more threads get created while trying to exit
	    (do ((pids other-pids (other-thread-pids)))
		((eq nil pids))
	      (map nil #'sb-thread:destroy-thread pids)
	      (sleep 0.2))
	    (return-from exit-cmd)))))
  (quit :unix-status status)
  (values))

(defun package-cmd (&optional pkg)
  (cond
    ((null pkg)
     (format *repl-output* "The ~A package is current.~%"
	     (package-name cl:*package*)))
    ((null (find-package (write-to-string pkg)))
     (format *repl-output* "Unknown package: ~A.~%" pkg))
    (t
     (setf cl:*package* (find-package (write-to-string pkg)))))
  (values))

(defun string-to-list-skip-spaces (str)
  "Return a list of strings, delimited by spaces, skipping spaces."
  (declare (type (or null string) str)) 
  (when str
    (loop for i = 0 then (1+ j)
	  as j = (position #\space str :start i)
	  when (not (char= (char str i) #\space))
	  collect (subseq str i j) while j)))

(let ((last-files-loaded nil))
  (defun ld-cmd (&optional string-files)
    (if string-files
	(setq last-files-loaded string-files)
	(setq string-files last-files-loaded))
    (dolist (arg (string-to-list-skip-spaces string-files))
      (let ((file 
	     (if (string= arg "~/" :end1 1 :end2 1)
		 (merge-pathnames (parse-namestring
				   (string-left-trim "~/" arg))
				  (user-homedir-pathname))
		 arg)))
	(format *repl-output* "loading ~S~%" file)
	(load file))))
  (values))

(defun cf-cmd (string-files)
  (when string-files
    (dolist (arg (string-to-list-skip-spaces string-files))
      (compile-file arg)))
  (values))

(defun >-num (x y)
  "Return if x and y are numbers, and x > y"
  (and (numberp x) (numberp y) (> x y)))

(defun newer-file-p (file1 file2)
  "Is file1 newer (written later than) file2?"
  (>-num (if (probe-file file1) (file-write-date file1))
	 (if (probe-file file2) (file-write-date file2))))

(defun compile-file-as-needed (src-path)
  "Compiles a file if needed, returns path."
  (let ((dest-path (compile-file-pathname src-path)))
    (when (or (not (probe-file dest-path))
	      (newer-file-p src-path dest-path))
      (ensure-directories-exist dest-path)
      (compile-file src-path :output-file dest-path))
    dest-path))

;;;; implementation of commands

(defun apropos-cmd (string)
  (apropos (string-upcase string))
  (values))

(let ((last-files-loaded nil))
  (defun cload-cmd (&optional string-files)
    (if string-files
	(setq last-files-loaded string-files)
	(setq string-files last-files-loaded))
    (dolist (arg (string-to-list-skip-spaces string-files))
      (format *repl-output* "loading ~a~%" arg)
      (load (compile-file-as-needed arg)))
    (values)))

(defun inspect-cmd (arg)
  (inspector arg nil *repl-output*)
  (values))

(defun istep-cmd (&optional arg-string)
  (istep (string-to-list-skip-spaces arg-string) *repl-output*)
  (values))

(defun describe-cmd (&rest args)
  (dolist (arg args)
    (eval `(describe ,arg)))
  (values))

(defun macroexpand-cmd (arg)
  (pprint (macroexpand arg) *repl-output*)
  (values))

(defun history-cmd ()
  (let ((n (length *history*)))
    (declare (fixnum n))
    (dotimes (i n)
      (declare (fixnum i))
      (let ((hist (nth (- n i 1) *history*)))
	(format *repl-output* "~3A " (user-cmd-hnum hist))
	(if (stringp (user-cmd-input hist))
	    (format *repl-output* "~A~%" (user-cmd-input hist))
	    (format *repl-output* "~W~%" (user-cmd-input hist))))))
  (values))

(defun help-cmd (&optional cmd)
  (cond
    (cmd
     (let ((cmd-entry (find-cmd cmd)))
       (if cmd-entry
	   (format *repl-output* "Documentation for ~A: ~A~%"
		   (cmd-table-entry-name cmd-entry)
		   (cmd-table-entry-desc cmd-entry)))))
    (t
     (format *repl-output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
     (format *repl-output* "~11A ~4A ~A~%" "<n>" ""
	     "re-execute <n>th history command")
     (dolist (doc-entry (get-cmd-doc-list :cmd))
       (format *repl-output* "~11A ~4A ~A~%" (first doc-entry)
	       (second doc-entry) (third doc-entry)))))
  (values))

(defun alias-cmd ()
  (let ((doc-entries (get-cmd-doc-list :alias)))
    (typecase doc-entries
      (cons
       (format *repl-output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
       (dolist (doc-entry doc-entries)
	 (format *repl-output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
      (t
       (format *repl-output* "No aliases are defined~%"))))
  (values))

(defun shell-cmd (string-arg)
  (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
		      :input nil :output *repl-output*)
  (values))

(defun pushd-cmd (string-arg)
  (push string-arg *dir-stack*)
  (cd-cmd *repl-output* string-arg)
  (values))

(defun popd-cmd ()
  (if *dir-stack*
      (let ((dir (pop *dir-stack*)))
	(cd-cmd dir))
      (format *repl-output* "No directory on stack to pop.~%"))
  (values))

(defun pop-cmd (&optional (n 1))
  (let ((new-level (- (length *break-stack*) n 1)))
    (when (minusp new-level)
      (setq new-level 0))
    (dotimes (i (- (length *break-stack*) new-level 1))
      (pop *break-stack*)))
  ;; Find inspector 
  (do* ((i (1- (length *break-stack*)) (1- i))
	(found nil))
       ((or found (minusp i)))
    (let ((inspect (break-data-inspect (nth i *break-stack*))))
      (when inspect
	(set-current-inspect inspect)
	(setq found t))))
  (values))

(defun continue-cmd (n)
  (let ((restarts (break-data-restarts (car *break-stack*))))
    (if restarts
	(if (< -1 n (length restarts))
	    (progn
	      (invoke-restart-interactively (nth n restarts))
	      )
	    (format *repl-output* "~&There is no such restart"))
	(format *repl-output* "~&There are no restarts"))))

(defun error-cmd ()
  )

(defun current-cmd ()
  )

(defun frame-cmd ()
  )

(defun zoom-cmd ()
  )

(defun local-cmd (&optional var)
  (declare (ignore var))
  )

(defun processes-cmd ()
  #+sb-thread
  (let ((pids (thread-pids))
	(current-pid (sb-thread:current-thread-id)))
    (dolist (pid pids)
      (format *repl-output* "~&~D" pid)
      (when (= pid current-pid)
	(format *repl-output* " [current listener]"))))
  #-sb-thread
  (format *repl-output* "~&Threads are not supported in this version of sbcl")
  (values))

(defun kill-cmd (&rest selected-pids)
  #+sb-thread
  (let ((pids (thread-pids)))
    (dolist (selected-pid selected-pids) 
      (if (find selected-pid pids :test #'eql)
	  (progn
	    (sb-thread:destroy-thread selected-pid)
	    (format *repl-output* "~&Thread ~A destroyed" selected-pid))
	  (format *repl-output* "~&No thread ~A exists" selected-pid))))
  #-sb-thread
  (declare (ignore selected-pids))
  #-sb-thread
  (format *repl-output* "~&Threads are not supported in this version of sbcl")
  (values))

(defun signal-cmd (signal &rest selected-pids)
  #+sb-thread
  (let ((pids (thread-pids)))
    (dolist (selected-pid selected-pids)
      (if (find selected-pid pids :test #'eql)
	  (progn
	    (sb-unix:unix-kill selected-pid signal)
	    (format *repl-output* "~&Signal ~A sent to thread ~A"
		    signal selected-pid))
	  (format *repl-output* "~&No thread ~A exists" selected-pid))))
  #-sb-thread
  (declare (ignore signal selected-pids))
  #-sb-thread
  (format *repl-output* "~&Threads are not supported in this version of sbcl")
  (values))

(defun focus-cmd (&optional process)
  #-sb-thread
  (declare (ignore process))
  #+sb-thread
  (when process
    (format *repl-output* "~&Focusing on next thread waiting waiting for the debugger~%"))
  #+sb-thread
  (progn
    (sb-thread:release-foreground)
    (sleep 1))
  #-sb-thread
  (format *repl-output* "~&Threads are not supported in this version of sbcl")
  (values))

(defun reset-cmd ()
  (setf *break-stack* (last *break-stack*))
  (values))

(defun dirs-cmd ()
  (dolist (dir *dir-stack*)
    (format *repl-output* "~a~%" dir))
  (values))


;;;; dispatch table for commands

(let ((cmd-table
       '(("aliases" 3 alias-cmd "show aliases")
	 ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
	 ("cd" 2 cd-cmd "change default diretory" :parsing :string)
	 ("ld" 2 ld-cmd "load a file" :parsing :string)
	 ("cf" 2 cf-cmd "compile file" :parsing :string)
	 ("cload" 2 cload-cmd "compile if needed and load file"
	  :parsing :string)
	 #+aclrepl-debugger("current" 3 current-cmd "print the expression for the current stack frame")
	 #+aclrepl-debugger ("continue" 4 continue-cmd "continue from a continuable error")
	 ("describe" 2 describe-cmd "describe an object")
	 ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
	 ("package" 2 package-cmd "change current package")
	 #+aclrepl-debugger ("error" 3 error-cmd "print the last error message")
	 ("exit" 2 exit-cmd "exit sbcl")
	 #+aclrepl-debugger("frame" 2 frame-cmd "print info about the current frame")
	 ("help" 2 help-cmd "print this help")
	 ("history" 3 history-cmd "print the recent history")
	 ("inspect" 2 inspect-cmd "inspect an object")
	 ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
	 #+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes")
	 #+sb-thread ("signal" 2 signal-cmd "send a signal to processes")
	 #+sb-thread ("focus" 2 focus-cmd "focus the top level on a process")
	 #+aclrepl-debugger("local" 3 local-cmd "print the value of a local variable")
	 ("pwd" 3 pwd-cmd "print current directory")
	 ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
	 ("pop" 3 pop-cmd "pop up `n' (default 1) break levels")
	 ("popd" 4 popd-cmd "pop directory from stack")
	 #+sb-thread ("processes" 3 processes-cmd "list all processes")
	 ("reset" 3 reset-cmd "reset to top break level")
	 ("trace" 2 trace-cmd "trace a function")
	 ("untrace" 4 untrace-cmd "untrace a function")
	 ("dirs" 2 dirs-cmd "show directory stack")
	 ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string)
	 #+aclrepl-debugger ("zoom" 2 zoom-cmd "print the runtime stack")
	 )))
  (dolist (cmd cmd-table)
    (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
      (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))

;;;; machinery for aliases

(defsetf alias (name &key abbr-len description) (user-func)
  `(progn
    (%add-entry
     (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len))
    (quote ,name)))

(defmacro alias (name-param args &rest body)
  (let ((parsing nil)
	(desc "")
	(abbr-index nil)
	(name (if (atom name-param)
		  name-param
		  (car name-param))))
    (when (consp name-param)
     (dolist (param (cdr name-param))
	(cond
	  ((or
	    (eq param :case-sensitive)
	    (eq param :string))
	   (setq parsing param))
	  ((stringp param)
	   (setq desc param))
	  ((numberp param)
	   (setq abbr-index param)))))
    `(progn
      (%add-entry
       (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index
									       (1+ ,abbr-index)))
       ,abbr-index)
      ,name)))
       
    
(defun remove-alias (&rest aliases)
  (declare (list aliases))
  (let ((keys '())
	(remove-all (not (null (find :all aliases)))))
    (unless remove-all  ;; ensure all alias are strings
      (setq aliases
	    (loop for alias in aliases
		  collect
		  (etypecase alias
		    (string
		     alias)
		    (symbol
		     (symbol-name alias))))))
    (maphash
     (lambda (key cmd)
       (when (eq (cmd-table-entry-group cmd) :alias)
	 (if remove-all
	     (push key keys)
	     (when (some
		    (lambda (alias)
		      (let ((klen (length key)))
			(and (>= (length alias) klen)
			     (string-equal (subseq alias 0 klen)
					   (subseq key 0 klen)))))
		    aliases)
	       (push key keys)))))
     *cmd-table-hash*)
    (dolist (key keys)
      (remhash key *cmd-table-hash*))
    keys))

;;;; low-level reading/parsing functions

;;; Skip white space (but not #\NEWLINE), and peek at the next
;;; character.
(defun peek-char-non-whitespace (&optional stream)
  (do ((char (peek-char nil stream nil *eof-marker*)
	     (peek-char nil stream nil *eof-marker*)))
      ((not (whitespace-char-not-newline-p char)) char)
    (read-char stream)))

(defun string-trim-whitespace (str)
  (string-trim '(#\space #\tab #\return)
	       str))

(defun whitespace-char-not-newline-p (x)
  (and (characterp x)
       (or (char= x #\space)
	   (char= x #\tab)
	   (char= x #\return))))


;;;; linking into SBCL hooks


(defun repl-prompt-fun (stream)
  (let* ((break-data (car *break-stack*))
	 (break-level (break-data-level break-data)))
    (when (zerop break-level)
      (setq break-level nil))
    #+sb-thread
    (let ((lock sb-thread::*session-lock*))
      (sb-thread::get-foreground)
      (let ((stopped-threads (sb-thread::waitqueue-data lock)))
	(when stopped-threads
	  (format stream "~{~&Thread ~A suspended~}~%" stopped-threads))))
    (if (functionp *prompt*)
	(write-string (funcall *prompt* break-level
			       (break-data-inspect-initiated break-data)
			       (break-data-continuable break-data)
			       (prompt-package-name) *cmd-number*)
		      stream)
	(handler-case 
	    (format nil *prompt* break-level
		    (break-data-inspect-initiated break-data)
		    (break-data-continuable break-data)
		    (prompt-package-name) *cmd-number*)
	  (error ()
	    (format stream "~&Prompt error>  "))
	  (:no-error (prompt)
	    (format stream "~&~A" prompt))))))
  
(defun process-cmd (user-cmd input-stream output-stream)
  ;; Processes a user command. Returns t if the user-cmd was a top-level
  ;; command
  (cond ((eq user-cmd *eof-cmd*)
	 (when *exit-on-eof*
	   (quit))
	 (format output-stream "EOF~%")
	 t)
	((eq user-cmd *null-cmd*)
	 t)
	((eq (user-cmd-func user-cmd) :cmd-error)
	 (format output-stream "Unknown top-level command: ~s.~%"
		 (user-cmd-input user-cmd))
	 (format output-stream "Type `:help' for the list of commands.~%")
	 t)
	((eq (user-cmd-func user-cmd) :history-error)
	 (format output-stream "Input numbered ~d is not on the history list~%"
		 (user-cmd-input user-cmd))
	 t)
	((functionp (user-cmd-func user-cmd))
	 (add-to-history user-cmd)
	 (let ((*repl-output* output-stream)
	       (*repl-input* input-stream))
	   (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd)))
	 (fresh-line)
	 t)
	(t
	 (add-to-history user-cmd)
	 nil))) ; nope, not in my job description

(defun repl-read-form-fun (input-stream output-stream)
  ;; Pick off all the leading ACL magic commands, then return a normal
  ;; Lisp form.
  (loop for user-cmd = (read-cmd input-stream) do
	(if (process-cmd user-cmd input-stream output-stream)
	    (progn
	      (funcall sb-int:*repl-prompt-fun* output-stream)
	      (force-output output-stream))
	    (return (user-cmd-input user-cmd)))))


(setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
      sb-int:*repl-read-form-fun* #'repl-read-form-fun)

;;; Break level processing

;; use an initial break-level to hold current inspect toplevel at
;; break-level 0

(defun new-break (&key restarts inspect continuable)
  (push
   (make-break-data :level (length *break-stack*)
		    :restarts restarts
		    :inspect inspect
		    :inspect-initiated (when inspect t)
		    :continuable continuable)
   *break-stack*))

(defun set-break-inspect (inspect)
  "sets the inspect data for the current break level"
  (setf (break-data-inspect (car *break-stack*)) inspect))

) ;; close special variables bindings