;;;; 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
(args nil) ; args for cmd func
(hnum nil)) ; history number
-(defstruct break-data
- ;; numeric break level
- level
- ;; inspect data for a break level
- inspect
- ;; T when break initiated by an inspect
- inspect-initiated
- ;; restarts list for a break level
- restarts
- ;; T if break level is a continuable break
- continuable)
;;; cmd table entry
(defstruct cmd-table-entry
(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.")
"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.")
"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")
+
+(defvar *input*)
+(defvar *output*)
(declaim (type list *history*))
(defparameter *cmd-table-hash*
(make-hash-table :size 30 :test #'equal))
-;; Set up binding for multithreading
-
-(let ((*prompt* #.*default-prompt*)
- (*use-short-package-name* t)
- (*dir-stack* nil)
- (*command-char* #\:)
- (*max-history* 24)
- (*exit-on-eof* t)
- (*history* nil)
- (*cmd-number* 1)
- (*repl-output* nil)
- (*repl-input* nil)
- (*break-stack* (list (make-break-data :level 0)))
- )
-
(defun prompt-package-name ()
(if *use-short-package-name*
(car (sort (append
(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
(loop as arg = (read string-stream nil eof)
until (eq arg eof)
collect arg))))))
- (let ((next-char (peek-char-non-whitespace input-stream)))
- (cond
- ((eql next-char *command-char*)
- (let* ((line (string-trim-whitespace (read-line input-stream)))
- (first-space-pos (position #\space line))
- (cmd-string (subseq line 1 first-space-pos))
- (cmd-args-string
- (if first-space-pos
- (string-trim-whitespace (subseq line first-space-pos))
- "")))
- (declare (string line))
- (if (numberp (read-from-string cmd-string))
- (let ((cmd (get-history (read-from-string cmd-string))))
- (if (eq cmd *null-cmd*)
- (make-user-cmd :func :history-error
- :input (read-from-string cmd-string))
- (make-user-cmd :func (user-cmd-func cmd)
- :input (user-cmd-input cmd)
- :args (user-cmd-args cmd)
- :hnum *cmd-number*)))
- (let ((cmd-entry (find-cmd cmd-string)))
- (if cmd-entry
- (make-user-cmd :func (cmd-table-entry-func cmd-entry)
- :input line
- :args (parse-args
- (cmd-table-entry-parsing cmd-entry)
- cmd-args-string)
- :hnum *cmd-number*)
- (make-user-cmd :func :cmd-error
- :input cmd-string)
- )))))
- ((eql next-char #\newline)
- (read-char input-stream)
- *null-cmd*)
- (t
- (let* ((eof (cons nil *eof-marker*))
- (form (read input-stream nil eof)))
- (if (eq form eof)
- *eof-cmd*
- (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
-
+ (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
(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*)))
(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))
`(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)))
+ (let ((offset (* 4 sb-vm::thread-os-thread-slot)))
(sb-thread::mapcar-threads
#'(lambda (sap) (sb-sys:sap-ref-32 sap offset)))))
#+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*))))
+ (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))))
(map nil #'sb-thread:destroy-thread pids)
(sleep 0.2))
(return-from exit-cmd)))))
- (quit :unix-status status)
+ (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 (string str))
+ (declare (type (or null string) str))
(when str
(loop for i = 0 then (1+ j)
as j = (position #\space str :start i)
(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)
(defun apropos-cmd (string)
(apropos (string-upcase string))
+ (fresh-line *output*)
(values))
(let ((last-files-loaded nil))
(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)
(values))
(defun macroexpand-cmd (arg)
- (pprint (macroexpand arg) *repl-output*)
+ (pprint (macroexpand arg) *output*)
(values))
(defun history-cmd ()
(dotimes (i n)
(declare (fixnum i))
(let ((hist (nth (- n i 1) *history*)))
- (format *repl-output* "~3A " (user-cmd-hnum hist))
+ (format *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))))))
+ (format *output* "~A~%" (user-cmd-input hist))
+ (format *output* "~W~%" (user-cmd-input hist))))))
(values))
(defun help-cmd (&optional cmd)
(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* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
- (format *repl-output* "~11A ~4A ~A~%" "<n>" ""
+ (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* "~11A ~4A ~A~%" (first doc-entry)
+ (format *output* "~11A ~4A ~A~%" (first doc-entry)
(second doc-entry) (third doc-entry)))))
(values))
(let ((doc-entries (get-cmd-doc-list :alias)))
(typecase doc-entries
(cons
- (format *repl-output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
+ (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
(dolist (doc-entry doc-entries)
- (format *repl-output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
+ (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))
- (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))))
+ (cond
+ (*inspect-break*
+ (throw 'repl-catcher (values :inspect n)))
+ ((plusp *break-level*)
+ (throw 'repl-catcher (values :pop n))))
(values))
-(defun continue-cmd (n)
- (let ((restarts (break-data-restarts (car *break-stack*))))
+(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))
- (progn
- (invoke-restart-interactively (nth n restarts))
- )
- (format *repl-output* "~&There is no such restart"))
- (format *repl-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 ()
- )
-
-(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
(let ((pids (thread-pids))
(current-pid (sb-thread:current-thread-id)))
(dolist (pid pids)
- (format *repl-output* "~&~D" pid)
+ (format *output* "~&~D" pid)
(when (= pid current-pid)
- (format *repl-output* " [current listener]"))))
+ (format *output* " [current listener]"))))
#-sb-thread
- (format *repl-output* "~&Threads are not supported in this version of sbcl")
+ (format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun kill-cmd (&rest selected-pids)
(if (find selected-pid pids :test #'eql)
(progn
(sb-thread:destroy-thread selected-pid)
- (format *repl-output* "~&Thread ~A destroyed" selected-pid))
- (format *repl-output* "~&No thread ~A exists" selected-pid))))
+ (format *output* "~&Thread ~A destroyed" selected-pid))
+ (format *output* "~&No thread ~A exists" selected-pid))))
#-sb-thread
(declare (ignore selected-pids))
#-sb-thread
- (format *repl-output* "~&Threads are not supported in this version of sbcl")
+ (format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun signal-cmd (signal &rest selected-pids)
(if (find selected-pid pids :test #'eql)
(progn
(sb-unix:unix-kill selected-pid signal)
- (format *repl-output* "~&Signal ~A sent to thread ~A"
+ (format *output* "~&Signal ~A sent to thread ~A"
signal selected-pid))
- (format *repl-output* "~&No thread ~A exists" selected-pid))))
+ (format *output* "~&No thread ~A exists" selected-pid))))
#-sb-thread
- (declare (ignore selected-pids))
+ (declare (ignore signal selected-pids))
#-sb-thread
- (format *repl-output* "~&Threads are not supported in this version of sbcl")
+ (format *output* "~&Threads are not supported in this version of sbcl")
(values))
-(defun release-foreground-cmd ()
+(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
- #-sb-thread
- (format *repl-output* "~&Threads are not supported in this version of sbcl")
+ (format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun reset-cmd ()
- (setf *break-stack* (last *break-stack*))
- (values))
+ (throw 'sb-impl::toplevel-catcher nil))
(defun dirs-cmd ()
(dolist (dir *dir-stack*)
- (format *repl-output* "~a~%" dir))
+ (format *output* "~a~%" dir))
(values))
\f
(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)
- #+aclrepl-debugger("current" 3 current-cmd "print the expression for the current stack frame")
- #+aclrepl-debugger ("continue" 4 continue-cmd "continue from a continuable error")
+ ("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")
- #+aclrepl-debugger ("error" 3 error-cmd "print the last error message")
+ ("error" 3 error-cmd "print the last error message")
("exit" 2 exit-cmd "exit sbcl")
- #+aclrepl-debugger("frame" 2 frame-cmd "print info about the current frame")
+ ("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 ("rf" 2 release-foreground-cmd "release foreground")
- #+aclrepl-debugger("local" 3 local-cmd "print the value of a local variable")
+ #+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)
- #+aclrepl-debugger ("zoom" 2 zoom-cmd "print the runtime stack")
+ ("zoom" 2 zoom-cmd "print the runtime stack")
)))
(dolist (cmd cmd-table)
(destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
(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))))
\f
;;;; linking into SBCL hooks
-
(defun repl-prompt-fun (stream)
- (let* ((break-data (car *break-stack*))
- (break-level (break-data-level break-data)))
- (when (zerop break-level)
- (setq break-level nil))
- #+sb-thread
- (let ((lock sb-thread::*session-lock*))
- (sb-thread::get-foreground)
- (let ((stopped-threads (sb-thread::waitqueue-data lock)))
- (when stopped-threads
- (format stream "~{~&Thread ~A suspended~}~%" stopped-threads))))
+ (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
- (break-data-inspect-initiated break-data)
- (break-data-continuable break-data)
+ (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
- (break-data-inspect-initiated break-data)
- (break-data-continuable break-data)
+ (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 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
- (funcall sb-int:*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)
-;;; 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
-
+(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))