X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Frepl.lisp;h=d1c48f229934b4ec87f80f5d42a43d69b1d26120;hb=c117d67f59ebda806f168f31fb2c6b0962d997e6;hp=cb67b918f1f16d0a3daf82a5bb7da46a782a29e7;hpb=83c1b8bca82fc165b01332ef9e5c031c64d758d8;p=sbcl.git

diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp
index cb67b91..d1c48f2 100644
--- a/contrib/sb-aclrepl/repl.lisp
+++ b/contrib/sb-aclrepl/repl.lisp
@@ -15,8 +15,27 @@
 
 (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) 
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defparameter *default-prompt* "~&~A(~d): "
+  (defparameter *default-prompt* "~:[~2*~;[~:*~D~:[~;i~]~:[~;c~]] ~]~A(~D): "
     "The default prompt."))
 (defparameter *prompt* #.*default-prompt*
   "The current prompt string or formatter function.")
@@ -34,16 +53,15 @@
   "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*))
 
-(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
-
 (defvar *eof-marker* (cons :eof nil))
 (defvar *eof-cmd* (make-user-cmd :func :eof))
 (defvar *null-cmd* (make-user-cmd :func :null-cmd))
@@ -60,7 +78,11 @@
       (*max-history* 24)
       (*exit-on-eof* t)
       (*history* nil)
-      (*cmd-number* 1))
+      (*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*
@@ -129,16 +151,20 @@
   (func nil) ; function handler
   (desc nil) ; short description
   (parsing nil) ; (:string :case-sensitive nil)
-  (group nil)) ; command group (:cmd or :alias)
+  (group nil) ; command group (:cmd or :alias)
+  (abbr-len 0)) ; abbreviation length
   
-(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))
@@ -152,7 +178,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)
@@ -182,13 +208,18 @@
   (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)))
 
-(defun cd-cmd (output-stream &optional string-dir)
+(defun cd-cmd (&optional string-dir)
   (cond
     ((or (zerop (length string-dir))
 	 (string= string-dir "~"))
@@ -197,23 +228,23 @@
      (let ((new (truename string-dir)))
        (when (pathnamep new)
 	 (setf cl:*default-pathname-defaults* new)))))
-  (format output-stream "~A~%" (namestring cl:*default-pathname-defaults*))
+  (format *repl-output* "~A~%" (namestring cl:*default-pathname-defaults*))
   (values))
 
-(defun pwd-cmd (output-stream)
-  (format output-stream "Lisp's current working directory is ~s.~%"
+(defun pwd-cmd ()
+  (format *repl-output* "Lisp's current working directory is ~s.~%"
 	  (namestring cl:*default-pathname-defaults*))
   (values))
 
-(defun trace-cmd (output-stream &rest args)
+(defun trace-cmd (&rest args)
   (if args
-      (format output-stream "~A~%" (eval (sb-debug::expand-trace args)))
-      (format output-stream "~A~%" (sb-debug::%list-traced-funs)))
+      (format *repl-output* "~A~%" (eval (sb-debug::expand-trace args)))
+      (format *repl-output* "~A~%" (sb-debug::%list-traced-funs)))
   (values))
 
-(defun untrace-cmd (output-stream &rest args)
+(defun untrace-cmd (&rest args)
   (if args
-      (format output-stream "~A~%"
+      (format *repl-output* "~A~%"
 	      (eval
 	       (sb-int:collect ((res))
 		(let ((current args))
@@ -224,21 +255,49 @@
 			      `(sb-debug::untrace-1 ,(pop current))
 			      `(sb-debug::untrace-1 ',name))))))
 		`(progn ,@(res) t))))
-      (format output-stream "~A~%" (eval (sb-debug::untrace-all))))
+      (format *repl-output* "~A~%" (eval (sb-debug::untrace-all))))
   (values))
 
-(defun exit-cmd (output-stream &optional (status 0))
-  (declare (ignore output-stream))
+#+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 (output-stream &optional pkg)
+(defun package-cmd (&optional pkg)
   (cond
     ((null pkg)
-     (format output-stream "The ~A package is current.~%"
+     (format *repl-output* "The ~A package is current.~%"
 	     (package-name cl:*package*)))
     ((null (find-package (write-to-string pkg)))
-     (format output-stream "Unknown package: ~A.~%" pkg))
+     (format *repl-output* "Unknown package: ~A.~%" pkg))
     (t
      (setf cl:*package* (find-package (write-to-string pkg)))))
   (values))
@@ -252,17 +311,16 @@
 	  collect (subseq str i j) while j)))
 
 (let ((last-files-loaded nil))
-  (defun ld-cmd (output-stream &optional string-files)
+  (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))
-      (format output-stream "loading ~a~%" arg)
+      (format *repl-output* "loading ~a~%" arg)
       (load arg)))
   (values))
 
-(defun cf-cmd (output-stream string-files)
-  (declare (ignore output-stream))
+(defun cf-cmd (string-files)
   (when string-files
     (dolist (arg (string-to-list-skip-spaces string-files))
       (compile-file arg)))
@@ -288,99 +346,164 @@
 
 ;;;; implementation of commands
 
-(defun apropos-cmd (output-stream string)
-  (declare (ignore output-stream))
+(defun apropos-cmd (string)
   (apropos (string-upcase string))
   (values))
 
 (let ((last-files-loaded nil))
-  (defun cload-cmd (output-stream &optional string-files)
+  (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 output-stream "loading ~a~%" arg)
+      (format *repl-output* "loading ~a~%" arg)
       (load (compile-file-as-needed arg)))
     (values)))
 
-(defun inspect-cmd (output-stream arg)
-  (inspector arg nil output-stream)
+(defun inspect-cmd (arg)
+  (inspector arg nil *repl-output*)
   (values))
 
-(defun istep-cmd (output-stream &optional arg-string)
-  (istep arg-string output-stream)
+(defun istep-cmd (&optional arg-string)
+  (istep arg-string *repl-output*)
   (values))
 
-(defun describe-cmd (output-stream &rest args)
-  (declare (ignore output-stream))
+(defun describe-cmd (&rest args)
   (dolist (arg args)
     (eval `(describe ,arg)))
   (values))
 
-(defun macroexpand-cmd (output-stream arg)
-  (pprint (macroexpand arg) output-stream)
+(defun macroexpand-cmd (arg)
+  (pprint (macroexpand arg) *repl-output*)
   (values))
 
-(defun history-cmd (output-stream)
+(defun history-cmd ()
   (let ((n (length *history*)))
     (declare (fixnum n))
     (dotimes (i n)
       (declare (fixnum i))
       (let ((hist (nth (- n i 1) *history*)))
-	(format output-stream "~3A ~A~%" (user-cmd-hnum hist)
-		(user-cmd-input hist)))))
+	(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 (output-stream &optional cmd)
+(defun help-cmd (&optional cmd)
   (cond
     (cmd
      (let ((cmd-entry (find-cmd cmd)))
        (if cmd-entry
-	   (format output-stream "Documentation for ~A: ~A~%"
+	   (format *repl-output* "Documentation for ~A: ~A~%"
 		   (cmd-table-entry-name cmd-entry)
 		   (cmd-table-entry-desc cmd-entry)))))
     (t
-     (format output-stream "~13A ~a~%" "Command" "Description")
-     (format output-stream "------------- -------------~%")
-     (format output-stream "~13A ~A~%" "n"
-	     "(for any number n) recall nth command from history list")
+     (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 output-stream "~13A ~A~%" (car doc-entry) (cadr doc-entry)))))
+       (format *repl-output* "~11A ~4A ~A~%" (first doc-entry)
+	       (second doc-entry) (third doc-entry)))))
   (values))
 
-(defun alias-cmd (output-stream)
+(defun alias-cmd ()
   (let ((doc-entries (get-cmd-doc-list :alias)))
     (typecase doc-entries
       (cons
-       (format output-stream "~13A ~a~%" "Alias" "Description")
-       (format output-stream "------------- -------------~%")
+       (format *repl-output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
        (dolist (doc-entry doc-entries)
-	 (format output-stream "~13A ~A~%" (car doc-entry) (cadr doc-entry))))
+	 (format *repl-output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
       (t
-       (format output-stream "No aliases are defined~%"))))
+       (format *repl-output* "No aliases are defined~%"))))
   (values))
 
-(defun shell-cmd (output-stream string-arg)
+(defun shell-cmd (string-arg)
   (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
-		      :input nil :output output-stream)
+		      :input nil :output *repl-output*)
   (values))
 
-(defun pushd-cmd (output-stream string-arg)
+(defun pushd-cmd (string-arg)
   (push string-arg *dir-stack*)
-  (cd-cmd output-stream string-arg)
+  (cd-cmd *repl-output* string-arg)
   (values))
 
-(defun popd-cmd (output-stream)
+(defun popd-cmd ()
   (if *dir-stack*
       (let ((dir (pop *dir-stack*)))
 	(cd-cmd dir))
-      (format output-stream "No directory on stack to pop.~%"))
+      (format *repl-output* "No directory on stack to pop.~%"))
   (values))
 
-(defun dirs-cmd (output-stream)
+(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 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 (selected-pid)
+  #+sb-thread
+  (let ((pids (thread-pids)))
+    (if (find selected-pid pids :test #'eql)
+	(progn
+	  (sb-thread:destroy-thread selected-pid)
+	  (format *repl-output* "Thread ~D destroyed" selected-pid))
+	(format *repl-output* "No thread ~D exists" selected-pid)))
+  #-sb-thread
+  (declare (ignore selected-pid))
+  #-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 output-stream "~a~%" dir))
+    (format *repl-output* "~a~%" dir))
   (values))
+
 
 ;;;; dispatch table for commands
 
@@ -392,17 +515,24 @@
 	 ("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)
+	 ("kill" 2 kill-cmd "kill a process")
 	 ("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")
+	 ("processes" 3 processes-cmd "list all processes")
 	 ("trace" 2 trace-cmd "trace a function")
 	 ("untrace" 4 untrace-cmd "untrace a function")
 	 ("dirs" 2 dirs-cmd "show directory stack")
@@ -413,10 +543,10 @@
 
 ;;;; 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)
@@ -439,7 +569,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)))
        
@@ -499,12 +630,27 @@
 ;;;; 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-data (car *break-stack*))
+	 (break-level (break-data-level break-data)))
+    (when (zerop break-level)
+      (setq break-level nil))
+    (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 output-stream)
+(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*)
@@ -525,7 +671,9 @@
 	 t)
 	((functionp (user-cmd-func user-cmd))
 	 (add-to-history user-cmd)
-	 (apply (user-cmd-func user-cmd) output-stream (user-cmd-args 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
@@ -536,7 +684,7 @@
   ;; 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 output-stream)
+	(if (process-cmd user-cmd input-stream output-stream)
 	    (progn
 	      (repl-prompt-fun output-stream)
 	      (force-output output-stream))
@@ -546,5 +694,23 @@
 (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