X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Frepl.lisp;h=db3c251d2faa44a8b3efe05c4867499a48159b66;hb=f7e3e709f7c2207f1923375942f7fb1c092f92b0;hp=7ae4fa195707251cacb901aebe0a1fd6a27d4d00;hpb=c486d57a174a2c9290d5db6ab803ec8c41ecc588;p=sbcl.git

diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp
index 7ae4fa1..db3c251 100644
--- a/contrib/sb-aclrepl/repl.lisp
+++ b/contrib/sb-aclrepl/repl.lisp
@@ -25,7 +25,7 @@
   (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*
     "~:[~3*~;[~:*~D~:[~;~:*:~D~]~:[~;i~]~:[~;c~]] ~]~A(~D): "
@@ -52,11 +52,6 @@
 
 (declaim (type list *history*))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(*prompt* *exit-on-eof* *max-history*
-	    *use-short-package-name* *command-char*
-	    alias)))
-
 (defvar *eof-marker* :eof)
 (defvar *eof-cmd* (make-user-cmd :func :eof))
 (defvar *null-cmd* (make-user-cmd :func :null-cmd))
@@ -64,61 +59,52 @@
 (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* 100)
-      (*exit-on-eof* t)
-      (*history* nil)
-      (*cmd-number* 1)
-      )
-      
 (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-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
-  (let ((next-char (peek-char-non-whitespace input-stream)))
-    (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*)))))))
+  (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))
-	      "")))
+         (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)))
+           (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) #\-))
+           (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))
@@ -128,59 +114,59 @@
 (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)))
+         (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))))
+        (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))
+  (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*)))))
+         (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*))))
+        *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))))
+           (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)))))
+        (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)
+      (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)))
 
@@ -188,54 +174,54 @@
 (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
-	      (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))))))
+           (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 ((cmd-entry (find-cmd cmd-string)))
       (unless cmd-entry
-	(return-from process-cmd-text
-	  (make-user-cmd :func :cmd-error :input cmd-string)))
+        (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*))))
-  
+                     :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 abbr-len)
   (let ((name (etypecase name-param
-		(string
-		 name-param)
-		(symbol
-		 (string-downcase (write-to-string 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)))))
+                          :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))))
+         (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)))))
+        (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*))
 
@@ -249,47 +235,47 @@
   (unless (and *history* (user-cmd= cmd (car *history*)))
     (when (>= (length *history*) *max-history*)
       (setq *history* (nbutlast *history*
-				(1+ (- (length *history*) *max-history*)))))
+                                (1+ (- (length *history*) *max-history*)))))
     (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*)))
+        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*)
+               (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 "~"))
+         (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)))))
+         (setf cl:*default-pathname-defaults* new)))))
   (format *output* "~A~%" (namestring cl:*default-pathname-defaults*))
   (values))
 
 (defun pwd-cmd ()
   (format *output* "Lisp's current working directory is ~s.~%"
-	  (namestring cl:*default-pathname-defaults*))
+          (namestring cl:*default-pathname-defaults*))
   (values))
 
 (defun trace-cmd (&rest args)
@@ -301,49 +287,47 @@
 (defun untrace-cmd (&rest args)
   (if args
       (format *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))))
+              (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 *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)))))
+(defun all-threads ()
+  "Return a list of all threads"
+  (sb-thread:list-all-threads))
 
 #+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 other-threads ()
+  "Returns a list of all threads except the current one"
+  (delete sb-thread:*current-thread* (all-threads)))
 
 (defun exit-cmd (&optional (status 0))
   #+sb-thread
-  (let ((other-pids (other-thread-pids)))
-    (when other-pids
+  (let ((other-threads (other-threads)))
+    (when other-threads
       (format *output* "There exists the following processes~%")
-      (format *output* "~{~5d~%~}" other-pids)
+      (format *output* "~{~A~%~}" other-threads)
       (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)))))
+        (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 ((threads other-threads (other-threads)))
+                ((eq nil threads))
+              (map nil #'sb-thread:destroy-thread threads)
+              (sleep 0.2))
+            (return-from exit-cmd)))))
   (sb-ext:quit :unix-status status)
   (values))
 
@@ -351,7 +335,7 @@
   (cond
     ((null pkg)
      (format *output* "The ~A package is current.~%"
-	     (package-name cl:*package*)))
+             (package-name cl:*package*)))
     ((null (find-package (write-to-string pkg)))
      (format *output* "Unknown package: ~A.~%" pkg))
     (t
@@ -360,27 +344,27 @@
 
 (defun string-to-list-skip-spaces (str)
   "Return a list of strings, delimited by spaces, skipping spaces."
-  (declare (type (or null string) str)) 
+  (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)))
+          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))
+        (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 *output* "loading ~S~%" file)
-	(load file))))
+      (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)
@@ -396,13 +380,13 @@
 (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))))
+         (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))
+              (newer-file-p src-path dest-path))
       (ensure-directories-exist dest-path)
       (compile-file src-path :output-file dest-path))
     dest-path))
@@ -411,20 +395,21 @@
 
 (defun apropos-cmd (string)
   (apropos (string-upcase string))
+  (fresh-line *output*)
   (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))
+        (setq last-files-loaded string-files)
+        (setq string-files last-files-loaded))
     (dolist (arg (string-to-list-skip-spaces string-files))
       (format *output* "loading ~a~%" arg)
       (load (compile-file-as-needed arg)))
     (values)))
 
 (defun inspect-cmd (arg)
-  (inspector-fun arg nil *output*)
+  (inspector-fun (eval arg) nil *output*)
   (values))
 
 (defun istep-cmd (&optional arg-string)
@@ -446,10 +431,10 @@
     (dotimes (i n)
       (declare (fixnum i))
       (let ((hist (nth (- n i 1) *history*)))
-	(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))))))
+        (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)
@@ -457,16 +442,16 @@
     (cmd
      (let ((cmd-entry (find-cmd cmd)))
        (if cmd-entry
-	   (format *output* "Documentation for ~A: ~A~%"
-		   (cmd-table-entry-name cmd-entry)
-		   (cmd-table-entry-desc cmd-entry)))))
+           (format *output* "Documentation for ~A: ~A~%"
+                   (cmd-table-entry-name cmd-entry)
+                   (cmd-table-entry-desc cmd-entry)))))
     (t
      (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
      (format *output* "~11A ~4A ~A~%" "<n>" ""
-	     "re-execute <n>th history command")
+             "re-execute <n>th history command")
      (dolist (doc-entry (get-cmd-doc-list :cmd))
        (format *output* "~11A ~4A ~A~%" (first doc-entry)
-	       (second doc-entry) (third doc-entry)))))
+               (second doc-entry) (third doc-entry)))))
   (values))
 
 (defun alias-cmd ()
@@ -475,25 +460,25 @@
       (cons
        (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
        (dolist (doc-entry doc-entries)
-	 (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
+         (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
       (t
        (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 *output*)
+                      :input nil :output *output*)
   (values))
 
 (defun pushd-cmd (string-arg)
   (push string-arg *dir-stack*)
-  (cd-cmd *output* string-arg)
+  (cd-cmd string-arg)
   (values))
 
 (defun popd-cmd ()
   (if *dir-stack*
       (let ((dir (pop *dir-stack*)))
-	(cd-cmd dir))
+        (cd-cmd dir))
       (format *output* "No directory on stack to pop.~%"))
   (values))
 
@@ -520,55 +505,55 @@
 (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)))))
+             (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)))))
+             (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)))
+        (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)))))
+        (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*))
+  (sb-debug::print-frame-call sb-debug::*current-frame* t))
 
 (defun zoom-cmd ()
   )
@@ -579,43 +564,26 @@
 
 (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))
+  (dolist (thread (all-threads))
+    (format *output* "~&~A" thread)
+    (when (eq thread sb-thread:*current-thread*)
+      (format *output* " [current listener]")))
   #-sb-thread
   (format *output* "~&Threads are not supported in this version of sbcl")
   (values))
 
-(defun signal-cmd (signal &rest selected-pids)
+(defun sb-aclrepl::kill-cmd (&rest selected-threads)
   #+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))))
+  (dolist (thread selected-threads)
+    (let ((found (find thread (all-threads) :key 'sb-thread:thread-name
+                       :test 'equal)))
+      (if found
+          (progn
+            (format *output* "~&Destroying thread ~A" thread)
+            (sb-thread:destroy-thread found))
+          (format *output* "~&Thread ~A not found" thread))))
   #-sb-thread
-  (declare (ignore signal selected-pids))
+  (declare (ignore selected-threads))
   #-sb-thread
   (format *output* "~&Threads are not supported in this version of sbcl")
   (values))
@@ -635,8 +603,7 @@
   (values))
 
 (defun reset-cmd ()
-  ;; The last restart goes to the toplevel
-  (invoke-restart-interactively (car (last (compute-restarts)))))
+  (throw 'sb-impl::toplevel-catcher nil))
 
 (defun dirs-cmd ()
   (dolist (dir *dir-stack*)
@@ -648,45 +615,44 @@
 
 (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)
-	 ("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)
-	 ("zoom" 2 zoom-cmd "print the runtime stack")
-	 )))
+         ("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 ("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)
+         ("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)
+         ("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))))
@@ -701,56 +667,56 @@
 
 (defmacro alias (name-param args &rest body)
   (let ((parsing nil)
-	(desc "")
-	(abbr-index nil)
-	(name (if (atom name-param)
-		  name-param
-		  (car name-param))))
+        (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)))))
+        (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)))
+                                                                               (1+ ,abbr-index)))
        ,abbr-index)
       ,name)))
-       
-    
+
+
 (defun remove-alias (&rest aliases)
   (declare (list aliases))
   (let ((keys '())
-	(remove-all (not (null (find :all aliases)))))
+        (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))))))
+            (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)))))
+         (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*))
@@ -762,104 +728,117 @@
 ;;; character.
 (defun peek-char-non-whitespace (&optional stream)
   (do ((char (peek-char nil stream nil *eof-marker*)
-	     (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))
+               str))
 
 (defun whitespace-char-p (x)
   (and (characterp x)
        (or (char= x #\space)
-	   (char= x #\tab)
-	   (char= x #\newline)
-	   (char= x #\return))))
+           (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)
   (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
-    (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))))
+                       *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))))))
-  
+        (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)
   ;; 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*
-	   (sb-ext:quit))
-	 (format *output* "EOF~%")
-	 t)
-	((eq user-cmd *null-cmd*)
-	 t)
-	((eq (user-cmd-func user-cmd) :cmd-error)
-	 (format *output* "Unknown top-level command: ~s.~%"
-		 (user-cmd-input user-cmd))
-	 (format *output* "Type `:help' for the list of commands.~%")
-	 t)
-	((eq (user-cmd-func user-cmd) :history-error)
-	 (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)
-	 (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
+         (when *exit-on-eof*
+           (sb-ext:quit))
+         (format *output* "EOF~%")
+         t)
+        ((eq user-cmd *null-cmd*)
+         t)
+        ((eq (user-cmd-func user-cmd) :cmd-error)
+         (format *output* "Unknown top-level command: ~s.~%"
+                 (user-cmd-input user-cmd))
+         (format *output* "Type `~Ahelp' for the list of commands.~%" *command-char*)
+         t)
+        ((eq (user-cmd-func user-cmd) :history-error)
+         (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)
+         (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 output)
   ;; Pick off all the leading ACL magic commands, then return a normal
   ;; Lisp form.
   (let ((*input* input)
-	(*output* output))
+        (*output* output))
     (loop for user-cmd = (read-cmd *input*) do
-	(if (process-cmd user-cmd)
-	    (progn
-	      (funcall sb-int:*repl-prompt-fun* *output*)
-	      (force-output *output*))
-	    (return (user-cmd-input user-cmd))))))
+        (if (process-cmd user-cmd)
+            (progn
+              (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))