X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-aclrepl%2Frepl.lisp;h=17c2ad05ce7c1d8a43857431a8839af205dbbb51;hb=e8f691fc1ba5e3aebc74fd8723c7cc550a4f1e35;hp=69b63140994aab22fa61336dfe1b180ed8b73042;hpb=3e991f3ecd3a0a5ba50bc5b43c4ed0133c837701;p=sbcl.git diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 69b6314..17c2ad0 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,6 +47,9 @@ (defparameter *cmd-number* 1 "Number of the next command") +(defvar *input*) +(defvar *output*) + (declaim (type list *history*)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -82,6 +86,107 @@ (defun read-cmd (input-stream) ;; Reads a command from the user and returns a user-cmd object + (let ((next-char (peek-char-non-whitespace input-stream))) + (cond + ((eql *command-char* next-char) + (dispatch-command-line input-stream)) + ((eql #\newline next-char) + (read-char input-stream) + *null-cmd*) + ((eql :eof next-char) + *eof-cmd*) + (t + (let* ((eof (cons nil *eof-marker*)) + (form (read input-stream nil eof))) + (if (eq form eof) + *eof-cmd* + (make-user-cmd :input form :func nil :hnum *cmd-number*))))))) + +(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 +199,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 +411,7 @@ (defun apropos-cmd (string) (apropos (string-upcase string)) + (fresh-line *output*) (values)) (let ((last-files-loaded nil)) @@ -356,7 +425,7 @@ (values))) (defun inspect-cmd (arg) - (inspector arg nil *output*) + (inspector-fun arg nil *output*) (values)) (defun istep-cmd (&optional arg-string) @@ -430,48 +499,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 +636,8 @@ (values)) (defun reset-cmd () - #+ignore - (setf *break-stack* (last *break-stack*)) - (values)) + ;; The last restart goes to the toplevel + (invoke-restart-interactively (car (last (compute-restarts))))) (defun dirs-cmd () (dolist (dir *dir-stack*) @@ -546,6 +650,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) @@ -678,29 +787,37 @@ (defun repl-prompt-fun (stream) - (let ((break-level - (if (zerop *break-level*) nil *break-level*))) + (let ((break-level (when (plusp *break-level*) + *break-level*)) + (frame-number (when (and (plusp *break-level*) + sb-debug::*current-frame*) + (sb-di::frame-number sb-debug::*current-frame*)))) #+sb-thread (let ((lock sb-thread::*session-lock*)) (sb-thread::get-foreground) (let ((stopped-threads (sb-thread::waitqueue-data lock))) (when stopped-threads (format stream "~{~&Thread ~A suspended~}~%" stopped-threads)))) + (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 @@ -724,7 +841,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)