X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Frepl.lisp;h=9744e68f37853c0736fa11911a1d4d6257c7f31a;hb=644a1ff36dd578321fd0592aa47748e8af741542;hp=69b63140994aab22fa61336dfe1b180ed8b73042;hpb=3e991f3ecd3a0a5ba50bc5b43c4ed0133c837701;p=sbcl.git

diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp
index 69b6314..9744e68 100644
--- a/contrib/sb-aclrepl/repl.lisp
+++ b/contrib/sb-aclrepl/repl.lisp
@@ -27,7 +27,8 @@
   (abbr-len 0)) ; abbreviation length
   
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defparameter *default-prompt* "~:[~2*~;[~:*~D~:[~;i~]~:[~;c~]] ~]~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.")
@@ -46,12 +47,10 @@
 (defparameter *cmd-number* 1
   "Number of the next command")
 
-(declaim (type list *history*))
+(defvar *input*)
+(defvar *output*)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(*prompt* *exit-on-eof* *max-history*
-	    *use-short-package-name* *command-char*
-	    alias)))
+(declaim (type list *history*))
 
 (defvar *eof-marker* :eof)
 (defvar *eof-cmd* (make-user-cmd :func :eof))
@@ -60,18 +59,6 @@
 (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
@@ -82,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
@@ -94,53 +185,16 @@
 		(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))
-	   (cond
-	     ((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*))))
-	     ((or (zerop (length cmd-string))
-		  (whitespace-char-p (char cmd-string 0)))
-	      *null-cmd*)
-	     (t
-	      (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*)
-	((eql next-char :eof)
-	 *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 ((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 abbr-len)
   (let ((name (etypecase name-param
 		(string
@@ -343,6 +397,7 @@
 
 (defun apropos-cmd (string)
   (apropos (string-upcase string))
+  (fresh-line *output*)
   (values))
 
 (let ((last-files-loaded nil))
@@ -356,7 +411,7 @@
     (values)))
 
 (defun inspect-cmd (arg)
-  (inspector arg nil *output*)
+  (inspector-fun (eval arg) nil *output*)
   (values))
 
 (defun istep-cmd (&optional arg-string)
@@ -419,7 +474,7 @@
 
 (defun pushd-cmd (string-arg)
   (push string-arg *dir-stack*)
-  (cd-cmd *output* string-arg)
+  (cd-cmd string-arg)
   (values))
 
 (defun popd-cmd ()
@@ -430,48 +485,84 @@
   (values))
 
 (defun pop-cmd (&optional (n 1))
-  #+ignore
-  (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 
-  #+ignore
-  (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))))
-  (when *inspect-reason*
-      (throw 'inspect-quit nil))
+  (cond
+    (*inspect-break*
+     (throw 'repl-catcher (values :inspect n)))
+    ((plusp *break-level*)
+     (throw 'repl-catcher (values :pop n))))
   (values))
 
-(defun continue-cmd (&optional (n 0))
+(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
-	(if (< -1 n (length restarts))
-	    (invoke-restart-interactively (nth n restarts))
-	    (format *output* "~&There is no such restart"))
-	(format *output* "~&There are no 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 ()
-  (print-restarts))
-
-(defun current-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
@@ -531,9 +622,7 @@
   (values))
 
 (defun reset-cmd ()
-  #+ignore
-  (setf *break-stack* (last *break-stack*))
-  (values))
+  (invoke-restart-interactively (find-restart 'sb-impl::toplevel)))
 
 (defun dirs-cmd ()
   (dolist (dir *dir-stack*)
@@ -546,6 +635,11 @@
 (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)
@@ -666,41 +760,43 @@
   (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)
-  (let ((break-level
-	 (if (zerop *break-level*) nil  *break-level*)))
-    #+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))))
+  (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*
-			       *inspect-reason*
-			       *continuable-reason*
+			       break-level
+			       frame-number
+			       *inspect-break*
+			       *continuable-break*
 			       (prompt-package-name) *cmd-number*)
 		      stream)
 	(handler-case 
-	    (format nil *prompt* break-level
-		    *inspect-reason*
-		    *continuable-reason*
+	    (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))))))
+	    (format stream "~A" prompt))))))
   
 (defun process-cmd (user-cmd)
   ;; Processes a user command. Returns t if the user-cmd was a top-level
@@ -715,7 +811,7 @@
 	((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.~%")
+	 (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~%"
@@ -724,7 +820,7 @@
 	((functionp (user-cmd-func user-cmd))
 	 (add-to-history user-cmd)
 	 (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd))
-	 (fresh-line)
+	 ;;(fresh-line)
 	 t)
 	(t
 	 (add-to-history user-cmd)
@@ -746,5 +842,23 @@
 (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))