;;;; 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))
-
-
(cl:in-package :sb-aclrepl)
(defstruct user-cmd
(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.")
(declaim (type list *history*))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(*prompt* *exit-on-eof* *max-history*
- *use-short-package-name* *command-char*
- alias)))
-
(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* 100)
- (*exit-on-eof* t)
- (*history* nil)
- (*cmd-number* 1)
- )
-
(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))
- (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
#+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)))))
(defun apropos-cmd (string)
(apropos (string-upcase string))
+ (fresh-line *output*)
(values))
(let ((last-files-loaded nil))
(values)))
(defun inspect-cmd (arg)
- (inspector arg nil *output*)
+ (inspector-fun (eval arg) nil *output*)
(values))
(defun istep-cmd (&optional arg-string)
(defun pushd-cmd (string-arg)
(push string-arg *dir-stack*)
- (cd-cmd *output* string-arg)
+ (cd-cmd string-arg)
(values))
(defun popd-cmd ()
(values))
(defun pop-cmd (&optional (n 1))
- ;; Find inspector
- (when sb-impl::*inspect-break*
- (throw 'inspect-quit nil))
+ (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))
(defun continue-cmd (&optional (num 0))
;; don't look at first restart
- (let ((restarts (cdr (compute-restarts))))
+ (let ((restarts (compute-restarts)))
(if restarts
(let ((restart
(typecase num
(string= (symbol-name sym1)
(symbol-name sym2)))))
(t
- (format *output* "~S is invalid as a restart name.")
+ (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 ()
- (sb-debug::error-debug-command))
+ (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*))
(values))
(defun reset-cmd ()
- #+ignore
- (setf *break-stack* (last *break-stack*))
- (values))
+ (throw 'sb-impl::toplevel-catcher nil))
(defun dirs-cmd ()
(dolist (dir *dir-stack*)
(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-level (if (zerop sb-impl::*break-level*)
- nil sb-impl::*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*
- sb-impl::*inspect-break*
- sb-impl::*continuable-break*
+ break-level
+ frame-number
+ *inspect-break*
+ *continuable-break*
(prompt-package-name) *cmd-number*)
stream)
(handler-case
- (format nil *prompt* break-level
- sb-impl::*inspect-break*
- sb-impl::*continuable-break*
+ (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
((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~%"
((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)
(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))
projects / sbcl.git / blobdiff