X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Frepl.lisp;h=9744e68f37853c0736fa11911a1d4d6257c7f31a;hb=8a8a8922802460741d6f8f6c11d71b1f414cf3a7;hp=8de960aaf01893aa48fc76e372e4356d0bcc8701;hpb=976505f5476932372cae826a7bc5f3c94a09fa98;p=sbcl.git

diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp
index 8de960a..9744e68 100644
--- a/contrib/sb-aclrepl/repl.lisp
+++ b/contrib/sb-aclrepl/repl.lisp
@@ -7,16 +7,28 @@
 ;;;; 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
+
+
+;;; 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* "~&~A(~d): "
+  (defparameter *default-prompt*
+    "~:[~3*~;[~:*~D~:[~;~:*:~D~]~:[~;i~]~:[~;c~]] ~]~A(~D): "
     "The default prompt."))
 (defparameter *prompt* #.*default-prompt*
   "The current prompt string or formatter function.")
@@ -26,7 +38,7 @@
   "The top-level directory stack")
 (defparameter *command-char* #\:
   "Prefix character for a top-level command")
-(defvar *max-history* 24
+(defvar *max-history* 100
   "Maximum number of history commands to remember")
 (defvar *exit-on-eof* t
   "If T, then exit when the EOF character is entered.")
@@ -34,41 +46,19 @@
   "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")
 
-(declaim (type list *history*))
+(defvar *input*)
+(defvar *output*)
 
-(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
+(declaim (type list *history*))
 
-(defvar *eof-marker* (cons :eof nil))
+(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)
-      )
-      
 (defun prompt-package-name ()
   (if *use-short-package-name*
       (car (sort (append
@@ -79,6 +69,110 @@
 
 (defun read-cmd (input-stream)
   ;; Reads a command from the user and returns a user-cmd object
+  (let* ((next-char (peek-char-non-whitespace input-stream))
+	 (cmd (cond
+		((eql *command-char* next-char)
+		 (dispatch-command-line input-stream))
+		((eql #\newline next-char)
+		 (read-char input-stream)
+		 *null-cmd*)
+		((eql :eof next-char)
+		 *eof-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*)))))))
+    (if (and (eq cmd *eof-cmd*) (typep input-stream 'string-stream))
+	(throw 'repl-catcher cmd)
+	cmd)))
+
+(defun dispatch-command-line (input-stream)
+  "Processes an input line that starts with *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 (simple-string line))
+    (cond
+      ((or (zerop (length cmd-string))
+	   (whitespace-char-p (char cmd-string 0)))
+       *null-cmd*)
+      ((or (numberp (read-from-string cmd-string))
+	   (char= (char cmd-string 0) #\+)
+	   (char= (char cmd-string 0) #\-))
+       (process-cmd-numeric cmd-string cmd-args-string))
+      ((char= (char cmd-string 0) *command-char*)
+       (process-history-search (subseq cmd-string 1) cmd-args-string))
+      (t
+       (process-cmd-text cmd-string line cmd-args-string)))))
+
+(defun process-cmd-numeric (cmd-string cmd-args-string)
+  "Process a numeric cmd, such as ':123'"
+  (let* ((first-char (char cmd-string 0))
+	 (number-string (if (digit-char-p first-char)
+			    cmd-string
+			    (subseq cmd-string 1)))
+	 (is-minus (char= first-char #\-))
+	 (raw-number (read-from-string number-string))
+	 (number (if is-minus
+		     (- *cmd-number* raw-number)
+		     raw-number))
+	 (cmd (get-history number)))
+    (when (eq cmd *null-cmd*)
+      (return-from process-cmd-numeric
+	(make-user-cmd :func :history-error :input (read-from-string
+						    cmd-string))))
+    (maybe-return-history-cmd cmd cmd-args-string)))
+
+(defun maybe-return-history-cmd (cmd cmd-args-string)
+  (format *output* "~A~%" (user-cmd-input cmd))
+  (let ((dont-redo
+	 (when (and (stringp cmd-args-string)
+		    (plusp (length cmd-args-string))
+		    (char= #\? (char cmd-args-string 0)))
+	   (do ((line nil (read-line *input*)))
+	       ((and line (or (zerop (length line))
+			      (string-equal line "Y")
+			      (string-equal line "N")))
+		(when (string-equal line "N")
+		  t))
+	     (when line
+	       (format *output* "Type \"y\" for yes or \"n\" for no.~%"))
+	     (format *output* "redo? [y] ")
+	     (force-output *output*)))))
+    (if dont-redo
+	*null-cmd*
+	(make-user-cmd :func (user-cmd-func cmd)
+		       :input (user-cmd-input cmd)
+		       :args (user-cmd-args cmd)
+		       :hnum *cmd-number*))))
+
+
+(defun find-history-matching-pattern (cmd-string)
+  "Return history item matching cmd-string or NIL if not found"
+  (dolist (his *history* nil)
+    (let* ((input (user-cmd-input his))
+	   (string-input (if (stringp input)
+			     input
+			     (write-to-string input))))
+      (when (search cmd-string string-input :test #'string-equal)
+	(return-from find-history-matching-pattern his)))))
+
+(defun process-history-search (pattern cmd-args-string)
+  (let ((cmd (find-history-matching-pattern pattern)))
+    (unless cmd
+      (format *output* "No match on history list with pattern ~S~%" pattern)
+      (return-from process-history-search *null-cmd*))
+    (maybe-return-history-cmd cmd cmd-args-string)))
+
+
+(defun process-cmd-text (cmd-string line cmd-args-string)
+  "Process a text cmd, such as ':ld a b c'"
   (flet ((parse-args (parsing args-string)
 	   (case parsing
 	     (:string
@@ -86,66 +180,32 @@
 		  nil
 		  (list args-string)))
  	     (t
-	      (let ((string-stream (make-string-input-stream args-string)))
-		(loop as arg = (read string-stream nil *eof-marker*)
-		      until (eq arg *eof-marker*)
+	      (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 ((form (read input-stream nil *eof-marker*)))
-	 (if (eq form *eof-marker*)
-	     *eof-cmd*
-	     (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
-
-;;; 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)
+    (let ((cmd-entry (find-cmd cmd-string)))
+      (unless cmd-entry
+	(return-from process-cmd-text
+	  (make-user-cmd :func :cmd-error :input cmd-string)))
+      (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*))))
   
-(defun make-cte (name-param func desc parsing group)
+(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)))
+			  :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))
@@ -159,7 +219,7 @@
 
 (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)
+   (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len)
    abbr-len))
    
 (defun find-cmd (cmdstr)
@@ -174,7 +234,8 @@
 (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))))
+      (setq *history* (nbutlast *history*
+				(1+ (- (length *history*) *max-history*)))))
     (push cmd *history*)
     (incf *cmd-number*)))
 
@@ -189,9 +250,14 @@
   (let ((cmds '()))
     (maphash (lambda (k v)
 	       (when (and
-		      (eql (length k) (length (cmd-table-entry-name v)))
+		      (= (length k) (length (cmd-table-entry-name v)))
 		      (eq (cmd-table-entry-group v) group))
-		 (push (list k (cmd-table-entry-desc v)) cmds)))
+		 (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)))
 
@@ -204,23 +270,23 @@
      (let ((new (truename string-dir)))
        (when (pathnamep new)
 	 (setf cl:*default-pathname-defaults* new)))))
-  (format *repl-output* "~A~%" (namestring cl:*default-pathname-defaults*))
+  (format *output* "~A~%" (namestring cl:*default-pathname-defaults*))
   (values))
 
 (defun pwd-cmd ()
-  (format *repl-output* "Lisp's current working directory is ~s.~%"
+  (format *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)))
+      (format *output* "~A~%" (eval (sb-debug::expand-trace args)))
+      (format *output* "~A~%" (sb-debug::%list-traced-funs)))
   (values))
 
 (defun untrace-cmd (&rest args)
   (if args
-      (format *repl-output* "~A~%"
+      (format *output* "~A~%"
 	      (eval
 	       (sb-int:collect ((res))
 		(let ((current args))
@@ -231,49 +297,56 @@
 			      `(sb-debug::untrace-1 ,(pop current))
 			      `(sb-debug::untrace-1 ',name))))))
 		`(progn ,@(res) t))))
-      (format *repl-output* "~A~%" (eval (sb-debug::untrace-all))))
+      (format *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
-  (flet ((other-thread-pids ()
-	   (let* ((offset (* 4 sb-vm::thread-pid-slot))
-		  (pids (sb-thread::mapcar-threads
-			 #'(lambda (sap)
-			     (sb-sys:sap-ref-32 sap offset)))))
-	     (delete (sb-thread:current-thread-id) pids :test #'eql))))
-    (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)
+  (let ((other-pids (other-thread-pids)))
+    (when other-pids
+      (format *output* "There exists the following processes~%")
+      (format *output* "~{~5d~%~}" other-pids)
+      (format *output* "Do you want to exit lisp anyway [n]? ")
+      (force-output *output*)
+      (let ((input (string-trim-whitespace (read-line *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)))))
+  (sb-ext:quit :unix-status status)
   (values))
 
 (defun package-cmd (&optional pkg)
   (cond
     ((null pkg)
-     (format *repl-output* "The ~A package is current.~%"
+     (format *output* "The ~A package is current.~%"
 	     (package-name cl:*package*)))
     ((null (find-package (write-to-string pkg)))
-     (format *repl-output* "Unknown package: ~A.~%" pkg))
+     (format *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)
@@ -286,8 +359,14 @@
 	(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 arg)))
+      (let ((file 
+	     (if (string= arg "~/" :end1 1 :end2 1)
+		 (merge-pathnames (parse-namestring
+				   (string-left-trim "~/" arg))
+				  (user-homedir-pathname))
+		 arg)))
+	(format *output* "loading ~S~%" file)
+	(load file))))
   (values))
 
 (defun cf-cmd (string-files)
@@ -318,6 +397,7 @@
 
 (defun apropos-cmd (string)
   (apropos (string-upcase string))
+  (fresh-line *output*)
   (values))
 
 (let ((last-files-loaded nil))
@@ -326,16 +406,16 @@
 	(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)
+      (format *output* "loading ~a~%" arg)
       (load (compile-file-as-needed arg)))
     (values)))
 
 (defun inspect-cmd (arg)
-  (inspector arg nil *repl-output*)
+  (inspector-fun (eval arg) nil *output*)
   (values))
 
 (defun istep-cmd (&optional arg-string)
-  (istep arg-string *repl-output*)
+  (istep (string-to-list-skip-spaces arg-string) *output*)
   (values))
 
 (defun describe-cmd (&rest args)
@@ -344,7 +424,7 @@
   (values))
 
 (defun macroexpand-cmd (arg)
-  (pprint (macroexpand arg) *repl-output*)
+  (pprint (macroexpand arg) *output*)
   (values))
 
 (defun history-cmd ()
@@ -353,8 +433,10 @@
     (dotimes (i n)
       (declare (fixnum i))
       (let ((hist (nth (- n i 1) *history*)))
-	(format *repl-output* "~3A ~A~%" (user-cmd-hnum hist)
-		(user-cmd-input hist)))))
+	(format *output* "~3A " (user-cmd-hnum hist))
+	(if (stringp (user-cmd-input hist))
+	    (format *output* "~A~%" (user-cmd-input hist))
+	    (format *output* "~W~%" (user-cmd-input hist))))))
   (values))
 
 (defun help-cmd (&optional cmd)
@@ -362,50 +444,189 @@
     (cmd
      (let ((cmd-entry (find-cmd cmd)))
        (if cmd-entry
-	   (format *repl-output* "Documentation for ~A: ~A~%"
+	   (format *output* "Documentation for ~A: ~A~%"
 		   (cmd-table-entry-name cmd-entry)
 		   (cmd-table-entry-desc cmd-entry)))))
     (t
-     (format *repl-output* "~13A ~a~%" "Command" "Description")
-     (format *repl-output* "------------- -------------~%")
-     (format *repl-output* "~13A ~A~%" "n"
-	     "(for any number n) recall nth command from history list")
+     (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
+     (format *output* "~11A ~4A ~A~%" "<n>" ""
+	     "re-execute <n>th history command")
      (dolist (doc-entry (get-cmd-doc-list :cmd))
-       (format *repl-output* "~13A ~A~%" (car doc-entry) (cadr doc-entry)))))
+       (format *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* "~13A ~a~%" "Alias" "Description")
-       (format *repl-output* "------------- -------------~%")
+       (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
        (dolist (doc-entry doc-entries)
-	 (format *repl-output* "~13A ~A~%" (car doc-entry) (cadr doc-entry))))
+	 (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
       (t
-       (format *repl-output* "No aliases are defined~%"))))
+       (format *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*)
+		      :input nil :output *output*)
   (values))
 
 (defun pushd-cmd (string-arg)
   (push string-arg *dir-stack*)
-  (cd-cmd *repl-output* string-arg)
+  (cd-cmd 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.~%"))
+      (format *output* "No directory on stack to pop.~%"))
   (values))
 
+(defun pop-cmd (&optional (n 1))
+  (cond
+    (*inspect-break*
+     (throw 'repl-catcher (values :inspect n)))
+    ((plusp *break-level*)
+     (throw 'repl-catcher (values :pop n))))
+  (values))
+
+(defun bt-cmd (&optional (n most-positive-fixnum))
+  (sb-debug::backtrace n))
+
+(defun current-cmd ()
+  (sb-debug::describe-debug-command))
+
+(defun top-cmd ()
+  (sb-debug::frame-debug-command 0))
+
+(defun bottom-cmd ()
+  (sb-debug::bottom-debug-command))
+
+(defun up-cmd (&optional (n 1))
+  (dotimes (i n)
+    (if (and sb-debug::*current-frame*
+	     (sb-di:frame-up sb-debug::*current-frame*))
+	(sb-debug::up-debug-command)
+	(progn
+	  (format *output* "Top of the stack")
+	  (return-from up-cmd)))))
+
+(defun dn-cmd (&optional (n 1))
+  (dotimes (i n)
+    (if (and sb-debug::*current-frame*
+	     (sb-di:frame-down sb-debug::*current-frame*))
+	(sb-debug::down-debug-command)
+	(progn
+	  (format *output* "Bottom of the stack")
+	  (return-from dn-cmd)))))
+
+(defun continue-cmd (&optional (num 0))
+  ;; don't look at first restart
+  (let ((restarts (compute-restarts)))
+    (if restarts
+	(let ((restart
+	       (typecase num
+		 (unsigned-byte
+		  (if (< -1 num (length restarts))
+		      (nth num restarts)
+		      (progn
+			(format *output* "There is no such restart")
+			(return-from continue-cmd))))
+		 (symbol
+		  (find num (the list restarts)
+			:key #'restart-name
+			:test (lambda (sym1 sym2)
+				(string= (symbol-name sym1)
+					 (symbol-name sym2)))))
+		 (t
+		  (format *output* "~S is invalid as a restart name" num)
+		  (return-from continue-cmd nil)))))
+	  (when restart
+	    (invoke-restart-interactively restart)))
+    (format *output* "~&There are no restarts"))))
+
+(defun error-cmd ()
+  (when (plusp *break-level*)
+    (if *inspect-break*
+	(sb-debug::show-restarts (compute-restarts) *output*)
+	(let ((sb-debug::*debug-restarts* (compute-restarts)))
+	  (sb-debug::error-debug-command)))))
+
+(defun frame-cmd ()
+  (sb-debug::print-frame-call sb-debug::*current-frame*))
+
+(defun zoom-cmd ()
+  )
+
+(defun local-cmd (&optional var)
+  (declare (ignore var))
+  (sb-debug::list-locals-debug-command))
+
+(defun processes-cmd ()
+  #+sb-thread
+  (let ((pids (thread-pids))
+	(current-pid (sb-thread:current-thread-id)))
+    (dolist (pid pids)
+      (format *output* "~&~D" pid)
+      (when (= pid current-pid)
+	(format *output* " [current listener]"))))
+  #-sb-thread
+  (format *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 *output* "~&Thread ~A destroyed" selected-pid))
+	  (format *output* "~&No thread ~A exists" selected-pid))))
+  #-sb-thread
+  (declare (ignore selected-pids))
+  #-sb-thread
+  (format *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 *output* "~&Signal ~A sent to thread ~A"
+		    signal selected-pid))
+	  (format *output* "~&No thread ~A exists" selected-pid))))
+  #-sb-thread
+  (declare (ignore signal selected-pids))
+  #-sb-thread
+  (format *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 *output* "~&Focusing on next thread waiting waiting for the debugger~%"))
+  #+sb-thread
+  (progn
+    (sb-thread:release-foreground)
+    (sleep 1))
+  #-sb-thread
+  (format *output* "~&Threads are not supported in this version of sbcl")
+  (values))
+
+(defun reset-cmd ()
+  (invoke-restart-interactively (find-restart 'sb-impl::toplevel)))
+
 (defun dirs-cmd ()
   (dolist (dir *dir-stack*)
-    (format *repl-output* "~a~%" dir))
+    (format *output* "~a~%" dir))
   (values))
 
 
@@ -414,36 +635,54 @@
 (let ((cmd-table
        '(("aliases" 3 alias-cmd "show aliases")
 	 ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
+	 ("bottom" 3 bottom-cmd "move to bottom stack frame")
+	 ("top" 3 top-cmd "move to top stack frame")
+	 ("bt" 2 bt-cmd "backtrace `n' stack frames, default all")
+	 ("up" 2 up-cmd "move up `n' stack frames, default 1")
+	 ("dn" 2 dn-cmd "move down `n' stack frames, default 1")
 	 ("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)
+	 ("current" 3 current-cmd "print the expression for the current stack frame")
+	 ("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")
+	 ("error" 3 error-cmd "print the last error message")
 	 ("exit" 2 exit-cmd "exit sbcl")
+	 ("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")
+	 ("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)
-	 ("popd" 2 popd-cmd "pop directory from stack")
+	 ("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))))
+	 ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string)
+	 ("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) (user-func)
+(defsetf alias (name &key abbr-len description) (user-func)
   `(progn
     (%add-entry
-     (make-cte (quote ,name) ,user-func "" nil :alias))
+     (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len))
     (quote ,name)))
 
 (defmacro alias (name-param args &rest body)
@@ -466,7 +705,8 @@
 	   (setq abbr-index param)))))
     `(progn
       (%add-entry
-       (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias)
+       (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index
+									       (1+ ,abbr-index)))
        ,abbr-index)
       ,name)))
        
@@ -516,64 +756,109 @@
   (string-trim '(#\space #\tab #\return)
 	       str))
 
-(defun whitespace-char-not-newline-p (x)
+(defun whitespace-char-p (x)
   (and (characterp x)
        (or (char= x #\space)
 	   (char= x #\tab)
+	   (char= x #\page)
+	   (char= x #\newline)
 	   (char= x #\return))))
 
+(defun whitespace-char-not-newline-p (x)
+  (and (whitespace-char-p x)
+       (not (char= x #\newline))))
 
 ;;;; linking into SBCL hooks
 
 (defun repl-prompt-fun (stream)
-  (if (functionp *prompt*)
-      (write-string (funcall *prompt* (prompt-package-name) *cmd-number*)
-		    stream)
-      (format stream *prompt* (prompt-package-name) *cmd-number*)))
+  (let ((break-level (when (plusp *break-level*)
+		       *break-level*))
+	(frame-number (when (and (plusp *break-level*)
+				 sb-debug::*current-frame*)
+			(sb-di::frame-number sb-debug::*current-frame*))))
+    (sb-thread::get-foreground)
+    (fresh-line stream)
+    (if (functionp *prompt*)
+	(write-string (funcall *prompt*
+			       break-level
+			       frame-number
+			       *inspect-break*
+			       *continuable-break*
+			       (prompt-package-name) *cmd-number*)
+		      stream)
+	(handler-case 
+	    (format nil *prompt*
+		    break-level
+		    frame-number
+		    *inspect-break*
+		    *continuable-break*
+		    (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)
+(defun process-cmd (user-cmd)
   ;; 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~%")
+	   (sb-ext:quit))
+	 (format *output* "EOF~%")
 	 t)
 	((eq user-cmd *null-cmd*)
 	 t)
 	((eq (user-cmd-func user-cmd) :cmd-error)
-	 (format output-stream "Unknown top-level command: ~s.~%"
+	 (format *output* "Unknown top-level command: ~s.~%"
 		 (user-cmd-input user-cmd))
-	 (format output-stream "Type `:help' for the list of commands.~%")
+	 (format *output* "Type `~Ahelp' for the list of commands.~%" *command-char*)
 	 t)
 	((eq (user-cmd-func user-cmd) :history-error)
-	 (format output-stream "Input numbered ~d is not on the history list~%"
+	 (format *output* "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)
+	 (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)
+(defun repl-read-form-fun (input output)
   ;; 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)
+  (let ((*input* input)
+	(*output* output))
+    (loop for user-cmd = (read-cmd *input*) do
+	(if (process-cmd user-cmd)
 	    (progn
-	      (repl-prompt-fun output-stream)
-	      (force-output output-stream))
-	    (return (user-cmd-input user-cmd)))))
+	      (funcall sb-int:*repl-prompt-fun* *output*)
+	      (force-output *output*))
+	    (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)
 
-) ;; close special variables bindings
-
+(defmacro with-new-repl-state ((&rest vars) &body forms)
+  (let ((gvars (mapcar (lambda (var) (gensym (symbol-name var))) vars)))
+    `(let (,@(mapcar (lambda (var gvar) `(,gvar ,var)) vars gvars))
+      (lambda (noprint)
+	(let ((*noprint* noprint))
+	  (let (,@(mapcar (lambda (var gvar) `(,var ,gvar)) vars gvars))
+	    (unwind-protect
+		 (progn ,@forms)
+	      ,@(mapcar (lambda (var gvar) `(setf ,gvar ,var))
+			vars gvars))))))))
+	
+(defun make-repl-fun ()
+  (with-new-repl-state (*break-level* *inspect-break* *continuable-break*
+			*dir-stack* *command-char* *prompt*
+			*use-short-package-name* *max-history* *exit-on-eof*
+			*history* *cmd-number*)
+    (repl :noprint noprint :break-level 0)))
+
+(when (boundp 'sb-impl::*repl-fun-generator*)
+  (setq sb-impl::*repl-fun-generator* #'make-repl-fun))