X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Frepl.lisp;h=7997a79cbc21c05b9db7292b89c0c807644db07e;hb=2d68a49fe9d30f687da45cfe7a02b497cb91137c;hp=8de960aaf01893aa48fc76e372e4356d0bcc8701;hpb=976505f5476932372cae826a7bc5f3c94a09fa98;p=sbcl.git diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 8de960a..7997a79 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -7,16 +7,28 @@ ;;;; any given time, for this functionality is on the ACL website: ;;;; . -(cl:defpackage :sb-aclrepl - (:use :cl :sb-ext) - (:export #:*prompt* #:*exit-on-eof* #:*max-history* - #:*use-short-package-name* #:*command-char* - #:alias)) - (cl:in-package :sb-aclrepl) +(defstruct user-cmd + (input nil) ; input, maybe a string or form + (func nil) ; cmd func entered, overloaded + ; (:eof :null-cmd :cmd-error :history-error) + (args nil) ; args for cmd func + (hnum nil)) ; history number + + +;;; cmd table entry +(defstruct cmd-table-entry + (name nil) ; name of command + (func nil) ; function handler + (desc nil) ; short description + (parsing nil) ; (:string :case-sensitive nil) + (group nil) ; command group (:cmd or :alias) + (abbr-len 0)) ; abbreviation length + (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *default-prompt* "~&~A(~d): " + (defparameter *default-prompt* + "~:[~3*~;[~:*~D~:[~;~:*:~D~]~:[~;i~]~:[~;c~]] ~]~A(~D): " "The default prompt.")) (defparameter *prompt* #.*default-prompt* "The current prompt string or formatter function.") @@ -26,7 +38,7 @@ "The top-level directory stack") (defparameter *command-char* #\: "Prefix character for a top-level command") -(defvar *max-history* 24 +(defvar *max-history* 100 "Maximum number of history commands to remember") (defvar *exit-on-eof* t "If T, then exit when the EOF character is entered.") @@ -34,134 +46,182 @@ "History list") (defparameter *cmd-number* 1 "Number of the next command") -(defparameter *repl-output* nil - "The output stream for the repl") -(defparameter *repl-input* nil - "The input stream for the repl") -(declaim (type list *history*)) +(defvar *input*) +(defvar *output*) -(defstruct user-cmd - (input nil) ; input, maybe a string or form - (func nil) ; cmd func entered, overloaded - ; (:eof :null-cmd :cmd-error :history-error) - (args nil) ; args for cmd func - (hnum nil)) ; history number +(declaim (type list *history*)) -(defvar *eof-marker* (cons :eof nil)) +(defvar *eof-marker* :eof) (defvar *eof-cmd* (make-user-cmd :func :eof)) (defvar *null-cmd* (make-user-cmd :func :null-cmd)) (defparameter *cmd-table-hash* (make-hash-table :size 30 :test #'equal)) -;; Set up binding for multithreading - -(let ((*prompt* #.*default-prompt*) - (*use-short-package-name* t) - (*dir-stack* nil) - (*command-char* #\:) - (*max-history* 24) - (*exit-on-eof* t) - (*history* nil) - (*cmd-number* 1) - (*repl-output* nil) - (*repl-input* nil) - ) - (defun prompt-package-name () (if *use-short-package-name* (car (sort (append - (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 - (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))) - (loop as arg = (read string-stream nil *eof-marker*) - until (eq arg *eof-marker*) - 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*) + (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 - (let ((form (read input-stream nil *eof-marker*))) - (if (eq form *eof-marker*) - *eof-cmd* - (make-user-cmd :input form :func nil :hnum *cmd-number*)))))))) - -;;; cmd table entry -(defstruct cmd-table-entry - (name nil) ; name of command - (func nil) ; function handler - (desc nil) ; short description - (parsing nil) ; (:string :case-sensitive nil) - (group nil)) ; command group (:cmd or :alias) - -(defun make-cte (name-param func desc parsing group) + (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 + (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))) + (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 - 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))) + :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) + (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*)) @@ -174,120 +234,137 @@ (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*))) (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 - (eql (length k) (length (cmd-table-entry-name v))) - (eq (cmd-table-entry-group v) group)) - (push (list k (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))))) - (format *repl-output* "~A~%" (namestring cl:*default-pathname-defaults*)) + (setf cl:*default-pathname-defaults* new))))) + (format *output* "~A~%" (namestring cl:*default-pathname-defaults*)) (values)) (defun pwd-cmd () - (format *repl-output* "Lisp's current working directory is ~s.~%" - (namestring cl:*default-pathname-defaults*)) + (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~%" - (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 *repl-output* "~A~%" (eval (sb-debug::untrace-all)))) + (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)))) + (format *output* "~A~%" (eval (sb-debug::untrace-all)))) (values)) +#+sb-thread +(defun all-threads () + "Return a list of all threads" + (sb-thread:list-all-threads)) + +#+sb-thread +(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 - (flet ((other-thread-pids () - (let* ((offset (* 4 sb-vm::thread-pid-slot)) - (pids (sb-thread::mapcar-threads - #'(lambda (sap) - (sb-sys:sap-ref-32 sap offset))))) - (delete (sb-thread:current-thread-id) pids :test #'eql)))) - (let ((other-pids (other-thread-pids))) - (when other-pids - (format *repl-output* "There exists the following processes~%") - (format *repl-output* "~{~5d~%~}" other-pids) - (format *repl-output* "Do you want to exit lisp anyway [n]? ") - (force-output *repl-output*) - (let ((input (string-trim-whitespace (read-line *repl-input*)))) - (if (and (plusp (length input)) - (or (char= #\y (char input 0)) - (char= #\Y (char input 0)))) - ;; loop in case more threads get created while trying to exit - (do ((pids other-pids (other-thread-pids))) - ((eq nil pids)) - (map nil #'sb-thread:destroy-thread pids) - (sleep 0.2)) - (return-from exit-cmd)))))) - (quit :unix-status status) + (let ((other-threads (other-threads))) + (when other-threads + (format *output* "There exists the following processes~%") + (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 ((threads other-threads (other-threads))) + ((eq nil threads)) + (map nil #'sb-thread:destroy-thread threads) + (sleep 0.2)) + (return-from exit-cmd))))) + (sb-ext:exit :code status) (values)) (defun package-cmd (&optional pkg) (cond ((null pkg) - (format *repl-output* "The ~A package is current.~%" - (package-name cl:*package*))) + (format *output* "The ~A package is current.~%" + (package-name cl:*package*))) ((null (find-package (write-to-string pkg))) - (format *repl-output* "Unknown package: ~A.~%" pkg)) + (format *output* "Unknown package: ~A.~%" pkg)) (t (setf cl:*package* (find-package (write-to-string pkg))))) (values)) (defun string-to-list-skip-spaces (str) "Return a list of strings, delimited by spaces, skipping spaces." + (declare (type (or null string) str)) (when str (loop for i = 0 then (1+ j) - as j = (position #\space str :start i) - 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)) - (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) @@ -303,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)) @@ -318,24 +395,25 @@ (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 *repl-output* "loading ~a~%" arg) + (format *output* "loading ~a~%" arg) (load (compile-file-as-needed arg))) (values))) (defun inspect-cmd (arg) - (inspector arg nil *repl-output*) + (inspector-fun (eval arg) nil *output*) (values)) (defun istep-cmd (&optional arg-string) - (istep arg-string *repl-output*) + (istep (string-to-list-skip-spaces arg-string) *output*) (values)) (defun describe-cmd (&rest args) @@ -344,7 +422,7 @@ (values)) (defun macroexpand-cmd (arg) - (pprint (macroexpand arg) *repl-output*) + (pprint (macroexpand arg) *output*) (values)) (defun history-cmd () @@ -353,8 +431,10 @@ (dotimes (i n) (declare (fixnum i)) (let ((hist (nth (- n i 1) *history*))) - (format *repl-output* "~3A ~A~%" (user-cmd-hnum hist) - (user-cmd-input hist))))) + (format *output* "~3A " (user-cmd-hnum hist)) + (if (stringp (user-cmd-input hist)) + (format *output* "~A~%" (user-cmd-input hist)) + (format *output* "~W~%" (user-cmd-input hist)))))) (values)) (defun help-cmd (&optional cmd) @@ -362,50 +442,172 @@ (cmd (let ((cmd-entry (find-cmd cmd))) (if cmd-entry - (format *repl-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 *repl-output* "~13A ~a~%" "Command" "Description") - (format *repl-output* "------------- -------------~%") - (format *repl-output* "~13A ~A~%" "n" - "(for any number n) recall nth command from history list") + (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION") + (format *output* "~11A ~4A ~A~%" "" "" + "re-execute th history command") (dolist (doc-entry (get-cmd-doc-list :cmd)) - (format *repl-output* "~13A ~A~%" (car doc-entry) (cadr doc-entry))))) + (format *output* "~11A ~4A ~A~%" (first doc-entry) + (second doc-entry) (third doc-entry))))) (values)) (defun alias-cmd () (let ((doc-entries (get-cmd-doc-list :alias))) (typecase doc-entries (cons - (format *repl-output* "~13A ~a~%" "Alias" "Description") - (format *repl-output* "------------- -------------~%") + (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION") (dolist (doc-entry doc-entries) - (format *repl-output* "~13A ~A~%" (car doc-entry) (cadr doc-entry)))) + (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry)))) (t - (format *repl-output* "No aliases are defined~%")))) + (format *output* "No aliases are defined~%")))) (values)) (defun shell-cmd (string-arg) (sb-ext:run-program "/bin/sh" (list "-c" string-arg) - :input nil :output *repl-output*) + :input nil :output *output*) (values)) (defun pushd-cmd (string-arg) (push string-arg *dir-stack*) - (cd-cmd *repl-output* string-arg) + (cd-cmd string-arg) (values)) (defun popd-cmd () (if *dir-stack* (let ((dir (pop *dir-stack*))) - (cd-cmd dir)) - (format *repl-output* "No directory on stack to pop.~%")) + (cd-cmd dir)) + (format *output* "No directory on stack to pop.~%")) + (values)) + +(defun pop-cmd (&optional (n 1)) + (cond + (*inspect-break* + (throw 'repl-catcher (values :inspect n))) + ((plusp *break-level*) + (throw 'repl-catcher (values :pop n)))) + (values)) + +(defun bt-cmd (&optional (n most-positive-fixnum)) + (sb-debug::backtrace n)) + +(defun current-cmd () + (sb-debug::describe-debug-command)) + +(defun top-cmd () + (sb-debug::frame-debug-command 0)) + +(defun bottom-cmd () + (sb-debug::bottom-debug-command)) + +(defun up-cmd (&optional (n 1)) + (dotimes (i n) + (if (and sb-debug::*current-frame* + (sb-di:frame-up sb-debug::*current-frame*)) + (sb-debug::up-debug-command) + (progn + (format *output* "Top of the stack") + (return-from up-cmd))))) + +(defun dn-cmd (&optional (n 1)) + (dotimes (i n) + (if (and sb-debug::*current-frame* + (sb-di:frame-down sb-debug::*current-frame*)) + (sb-debug::down-debug-command) + (progn + (format *output* "Bottom of the stack") + (return-from dn-cmd))))) + +(defun continue-cmd (&optional (num 0)) + ;; don't look at first restart + (let ((restarts (compute-restarts))) + (if restarts + (let ((restart + (typecase num + (unsigned-byte + (if (< -1 num (length restarts)) + (nth num restarts) + (progn + (format *output* "There is no such restart") + (return-from continue-cmd)))) + (symbol + (find num (the list restarts) + :key #'restart-name + :test (lambda (sym1 sym2) + (string= (symbol-name sym1) + (symbol-name sym2))))) + (t + (format *output* "~S is invalid as a restart name" num) + (return-from continue-cmd nil))))) + (when restart + (invoke-restart-interactively restart))) + (format *output* "~&There are no restarts")))) + +(defun error-cmd () + (when (plusp *break-level*) + (if *inspect-break* + (sb-debug::show-restarts (compute-restarts) *output*) + (let ((sb-debug::*debug-restarts* (compute-restarts))) + (sb-debug::error-debug-command))))) + +(defun frame-cmd () + (sb-debug::print-frame-call sb-debug::*current-frame* t)) + +(defun zoom-cmd () + ) + +(defun local-cmd (&optional var) + (declare (ignore var)) + (sb-debug::list-locals-debug-command)) + +(defun processes-cmd () + #+sb-thread + (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 sb-aclrepl::kill-cmd (&rest selected-threads) + #+sb-thread + (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 selected-threads)) + #-sb-thread + (format *output* "~&Threads are not supported in this version of sbcl") + (values)) + +(defun focus-cmd (&optional process) + #-sb-thread + (declare (ignore process)) + #+sb-thread + (when process + (format *output* "~&Focusing on next thread waiting waiting for the debugger~%")) + #+sb-thread + (progn + (sb-thread:release-foreground) + (sleep 1)) + #-sb-thread + (format *output* "~&Threads are not supported in this version of sbcl") + (values)) + +(defun reset-cmd () + (throw 'sb-impl::toplevel-catcher nil)) + (defun dirs-cmd () (dolist (dir *dir-stack*) - (format *repl-output* "~a~%" dir)) + (format *output* "~a~%" dir)) (values)) @@ -413,90 +615,108 @@ (let ((cmd-table '(("aliases" 3 alias-cmd "show aliases") - ("apropos" 2 apropos-cmd "show apropos" :parsing :string) - ("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) - ("describe" 2 describe-cmd "describe an object") - ("macroexpand" 2 macroexpand-cmd "macroexpand an expression") - ("package" 2 package-cmd "change current package") - ("exit" 2 exit-cmd "exit sbcl") - ("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) - ("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") - ("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)))) + ("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)))) ;;;; 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) (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) + (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,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*)) @@ -508,72 +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-not-newline-p (x) +(defun whitespace-char-p (x) (and (characterp x) (or (char= x #\space) - (char= x #\tab) - (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) - (if (functionp *prompt*) - (write-string (funcall *prompt* (prompt-package-name) *cmd-number*) - stream) - (format stream *prompt* (prompt-package-name) *cmd-number*))) - -(defun process-cmd (user-cmd input-stream output-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::get-foreground) + (fresh-line stream) + (if (functionp *prompt*) + (write-string (funcall *prompt* + break-level + frame-number + *inspect-break* + *continuable-break* + (prompt-package-name) *cmd-number*) + stream) + (handler-case + (format nil *prompt* + break-level + frame-number + *inspect-break* + *continuable-break* + (prompt-package-name) *cmd-number*) + (error () + (format stream "~&Prompt error> ")) + (:no-error (prompt) + (format stream "~A" prompt)))))) + +(defun process-cmd (user-cmd) ;; 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~%") - t) - ((eq user-cmd *null-cmd*) - t) - ((eq (user-cmd-func user-cmd) :cmd-error) - (format output-stream "Unknown top-level command: ~s.~%" - (user-cmd-input user-cmd)) - (format output-stream "Type `:help' for the list of commands.~%") - t) - ((eq (user-cmd-func user-cmd) :history-error) - (format output-stream "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) - t) - (t - (add-to-history user-cmd) - nil))) ; nope, not in my job description - -(defun repl-read-form-fun (input-stream output-stream) + (when *exit-on-eof* + (sb-ext:exit)) + (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. - (loop for user-cmd = (read-cmd input-stream) do - (if (process-cmd user-cmd input-stream output-stream) - (progn - (repl-prompt-fun output-stream) - (force-output output-stream)) - (return (user-cmd-input user-cmd))))) + (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*) + (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))