1 ;;;; Replicate much of the ACL toplevel functionality in SBCL. Mostly
2 ;;;; this is portable code, but fundamentally it all hangs from a few
3 ;;;; SBCL-specific hooks like SB-INT:*REPL-READ-FUN* and
4 ;;;; SB-INT:*REPL-PROMPT-FUN*.
6 ;;;; The documentation, which may or may not apply in its entirety at
7 ;;;; any given time, for this functionality is on the ACL website:
8 ;;;; <http://www.franz.com/support/documentation/6.2/doc/top-level.htm>.
10 (cl:in-package :sb-aclrepl)
13 (input nil) ; input, maybe a string or form
14 (func nil) ; cmd func entered, overloaded
15 ; (:eof :null-cmd :cmd-error :history-error)
16 (args nil) ; args for cmd func
17 (hnum nil)) ; history number
21 (defstruct cmd-table-entry
22 (name nil) ; name of command
23 (func nil) ; function handler
24 (desc nil) ; short description
25 (parsing nil) ; (:string :case-sensitive nil)
26 (group nil) ; command group (:cmd or :alias)
27 (abbr-len 0)) ; abbreviation length
29 (eval-when (:compile-toplevel :load-toplevel :execute)
30 (defparameter *default-prompt*
31 "~:[~3*~;[~:*~D~:[~;~:*:~D~]~:[~;i~]~:[~;c~]] ~]~A(~D): "
32 "The default prompt."))
33 (defparameter *prompt* #.*default-prompt*
34 "The current prompt string or formatter function.")
35 (defparameter *use-short-package-name* t
36 "when T, use the shortnest package nickname in a prompt")
37 (defparameter *dir-stack* nil
38 "The top-level directory stack")
39 (defparameter *command-char* #\:
40 "Prefix character for a top-level command")
41 (defvar *max-history* 100
42 "Maximum number of history commands to remember")
43 (defvar *exit-on-eof* t
44 "If T, then exit when the EOF character is entered.")
45 (defparameter *history* nil
47 (defparameter *cmd-number* 1
48 "Number of the next command")
53 (declaim (type list *history*))
55 (eval-when (:compile-toplevel :load-toplevel :execute)
56 (export '(*prompt* *exit-on-eof* *max-history*
57 *use-short-package-name* *command-char*
60 (defvar *eof-marker* :eof)
61 (defvar *eof-cmd* (make-user-cmd :func :eof))
62 (defvar *null-cmd* (make-user-cmd :func :null-cmd))
64 (defparameter *cmd-table-hash*
65 (make-hash-table :size 30 :test #'equal))
67 ;; Set up binding for multithreading
69 (let ((*prompt* #.*default-prompt*)
70 (*use-short-package-name* t)
79 (defun prompt-package-name ()
80 (if *use-short-package-name*
82 (package-nicknames cl:*package*)
83 (list (package-name cl:*package*)))
84 (lambda (a b) (< (length a) (length b)))))
85 (package-name cl:*package*)))
87 (defun read-cmd (input-stream)
88 ;; Reads a command from the user and returns a user-cmd object
89 (let* ((next-char (peek-char-non-whitespace input-stream))
91 ((eql *command-char* next-char)
92 (dispatch-command-line input-stream))
93 ((eql #\newline next-char)
94 (read-char input-stream)
99 (let* ((eof (cons nil *eof-marker*))
100 (form (read input-stream nil eof)))
103 (make-user-cmd :input form :func nil :hnum *cmd-number*)))))))
104 (if (and (eq cmd *eof-cmd*) (typep input-stream 'string-stream))
105 (throw 'repl-catcher cmd)
108 (defun dispatch-command-line (input-stream)
109 "Processes an input line that starts with *command-char*"
110 (let* ((line (string-trim-whitespace (read-line input-stream)))
111 (first-space-pos (position #\space line))
112 (cmd-string (subseq line 1 first-space-pos))
115 (string-trim-whitespace (subseq line first-space-pos))
117 (declare (simple-string line))
119 ((or (zerop (length cmd-string))
120 (whitespace-char-p (char cmd-string 0)))
122 ((or (numberp (read-from-string cmd-string))
123 (char= (char cmd-string 0) #\+)
124 (char= (char cmd-string 0) #\-))
125 (process-cmd-numeric cmd-string cmd-args-string))
126 ((char= (char cmd-string 0) *command-char*)
127 (process-history-search (subseq cmd-string 1) cmd-args-string))
129 (process-cmd-text cmd-string line cmd-args-string)))))
131 (defun process-cmd-numeric (cmd-string cmd-args-string)
132 "Process a numeric cmd, such as ':123'"
133 (let* ((first-char (char cmd-string 0))
134 (number-string (if (digit-char-p first-char)
136 (subseq cmd-string 1)))
137 (is-minus (char= first-char #\-))
138 (raw-number (read-from-string number-string))
140 (- *cmd-number* raw-number)
142 (cmd (get-history number)))
143 (when (eq cmd *null-cmd*)
144 (return-from process-cmd-numeric
145 (make-user-cmd :func :history-error :input (read-from-string
147 (maybe-return-history-cmd cmd cmd-args-string)))
149 (defun maybe-return-history-cmd (cmd cmd-args-string)
150 (format *output* "~A~%" (user-cmd-input cmd))
152 (when (and (stringp cmd-args-string)
153 (plusp (length cmd-args-string))
154 (char= #\? (char cmd-args-string 0)))
155 (do ((line nil (read-line *input*)))
156 ((and line (or (zerop (length line))
157 (string-equal line "Y")
158 (string-equal line "N")))
159 (when (string-equal line "N")
162 (format *output* "Type \"y\" for yes or \"n\" for no.~%"))
163 (format *output* "redo? [y] ")
164 (force-output *output*)))))
167 (make-user-cmd :func (user-cmd-func cmd)
168 :input (user-cmd-input cmd)
169 :args (user-cmd-args cmd)
170 :hnum *cmd-number*))))
173 (defun find-history-matching-pattern (cmd-string)
174 "Return history item matching cmd-string or NIL if not found"
175 (dolist (his *history* nil)
176 (let* ((input (user-cmd-input his))
177 (string-input (if (stringp input)
179 (write-to-string input))))
180 (when (search cmd-string string-input :test #'string-equal)
181 (return-from find-history-matching-pattern his)))))
183 (defun process-history-search (pattern cmd-args-string)
184 (let ((cmd (find-history-matching-pattern pattern)))
186 (format *output* "No match on history list with pattern ~S~%" pattern)
187 (return-from process-history-search *null-cmd*))
188 (maybe-return-history-cmd cmd cmd-args-string)))
191 (defun process-cmd-text (cmd-string line cmd-args-string)
192 "Process a text cmd, such as ':ld a b c'"
193 (flet ((parse-args (parsing args-string)
196 (if (zerop (length args-string))
200 (let ((string-stream (make-string-input-stream args-string))
201 (eof (cons nil *eof-marker*))) ;new cons for eq uniqueness
202 (loop as arg = (read string-stream nil eof)
205 (let ((cmd-entry (find-cmd cmd-string)))
207 (return-from process-cmd-text
208 (make-user-cmd :func :cmd-error :input cmd-string)))
209 (make-user-cmd :func (cmd-table-entry-func cmd-entry)
211 :args (parse-args (cmd-table-entry-parsing cmd-entry)
213 :hnum *cmd-number*))))
215 (defun make-cte (name-param func desc parsing group abbr-len)
216 (let ((name (etypecase name-param
220 (string-downcase (write-to-string name-param))))))
221 (make-cmd-table-entry :name name :func func :desc desc
222 :parsing parsing :group group
223 :abbr-len (if abbr-len
227 (defun %add-entry (cmd &optional abbr-len)
228 (let* ((name (cmd-table-entry-name cmd))
232 (dotimes (i (length name))
233 (when (>= i (1- alen))
234 (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
237 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
239 (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len)
242 (defun find-cmd (cmdstr)
243 (gethash (string-downcase cmdstr) *cmd-table-hash*))
245 (defun user-cmd= (c1 c2)
246 "Returns T if two user commands are equal"
247 (and (eq (user-cmd-func c1) (user-cmd-func c2))
248 (equal (user-cmd-args c1) (user-cmd-args c2))
249 (equal (user-cmd-input c1) (user-cmd-input c2))))
251 (defun add-to-history (cmd)
252 (unless (and *history* (user-cmd= cmd (car *history*)))
253 (when (>= (length *history*) *max-history*)
254 (setq *history* (nbutlast *history*
255 (1+ (- (length *history*) *max-history*)))))
257 (incf *cmd-number*)))
259 (defun get-history (n)
260 (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
265 (defun get-cmd-doc-list (&optional (group :cmd))
266 "Return list of all commands"
268 (maphash (lambda (k v)
270 (= (length k) (length (cmd-table-entry-name v)))
271 (eq (cmd-table-entry-group v) group))
273 (if (= (cmd-table-entry-abbr-len v)
276 (subseq k 0 (cmd-table-entry-abbr-len v)))
277 (cmd-table-entry-desc v)) cmds)))
279 (sort cmds #'string-lessp :key #'car)))
281 (defun cd-cmd (&optional string-dir)
283 ((or (zerop (length string-dir))
284 (string= string-dir "~"))
285 (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
287 (let ((new (truename string-dir)))
288 (when (pathnamep new)
289 (setf cl:*default-pathname-defaults* new)))))
290 (format *output* "~A~%" (namestring cl:*default-pathname-defaults*))
294 (format *output* "Lisp's current working directory is ~s.~%"
295 (namestring cl:*default-pathname-defaults*))
298 (defun trace-cmd (&rest args)
300 (format *output* "~A~%" (eval (sb-debug::expand-trace args)))
301 (format *output* "~A~%" (sb-debug::%list-traced-funs)))
304 (defun untrace-cmd (&rest args)
306 (format *output* "~A~%"
308 (sb-int:collect ((res))
309 (let ((current args))
311 (unless current (return))
312 (let ((name (pop current)))
313 (res (if (eq name :function)
314 `(sb-debug::untrace-1 ,(pop current))
315 `(sb-debug::untrace-1 ',name))))))
316 `(progn ,@(res) t))))
317 (format *output* "~A~%" (eval (sb-debug::untrace-all))))
321 (defun thread-pids ()
322 "Return a list of the pids for all threads"
323 (let ((offset (* 4 sb-vm::thread-pid-slot)))
324 (sb-thread::mapcar-threads
325 #'(lambda (sap) (sb-sys:sap-ref-32 sap offset)))))
328 (defun other-thread-pids ()
329 "Returns a list of pids for all threads except the current process"
330 (delete (sb-thread:current-thread-id) (thread-pids) :test #'eql))
332 (defun exit-cmd (&optional (status 0))
334 (let ((other-pids (other-thread-pids)))
336 (format *output* "There exists the following processes~%")
337 (format *output* "~{~5d~%~}" other-pids)
338 (format *output* "Do you want to exit lisp anyway [n]? ")
339 (force-output *output*)
340 (let ((input (string-trim-whitespace (read-line *input*))))
341 (if (and (plusp (length input))
342 (or (char= #\y (char input 0))
343 (char= #\Y (char input 0))))
344 ;; loop in case more threads get created while trying to exit
345 (do ((pids other-pids (other-thread-pids)))
347 (map nil #'sb-thread:destroy-thread pids)
349 (return-from exit-cmd)))))
350 (sb-ext:quit :unix-status status)
353 (defun package-cmd (&optional pkg)
356 (format *output* "The ~A package is current.~%"
357 (package-name cl:*package*)))
358 ((null (find-package (write-to-string pkg)))
359 (format *output* "Unknown package: ~A.~%" pkg))
361 (setf cl:*package* (find-package (write-to-string pkg)))))
364 (defun string-to-list-skip-spaces (str)
365 "Return a list of strings, delimited by spaces, skipping spaces."
366 (declare (type (or null string) str))
368 (loop for i = 0 then (1+ j)
369 as j = (position #\space str :start i)
370 when (not (char= (char str i) #\space))
371 collect (subseq str i j) while j)))
373 (let ((last-files-loaded nil))
374 (defun ld-cmd (&optional string-files)
376 (setq last-files-loaded string-files)
377 (setq string-files last-files-loaded))
378 (dolist (arg (string-to-list-skip-spaces string-files))
380 (if (string= arg "~/" :end1 1 :end2 1)
381 (merge-pathnames (parse-namestring
382 (string-left-trim "~/" arg))
383 (user-homedir-pathname))
385 (format *output* "loading ~S~%" file)
389 (defun cf-cmd (string-files)
391 (dolist (arg (string-to-list-skip-spaces string-files))
396 "Return if x and y are numbers, and x > y"
397 (and (numberp x) (numberp y) (> x y)))
399 (defun newer-file-p (file1 file2)
400 "Is file1 newer (written later than) file2?"
401 (>-num (if (probe-file file1) (file-write-date file1))
402 (if (probe-file file2) (file-write-date file2))))
404 (defun compile-file-as-needed (src-path)
405 "Compiles a file if needed, returns path."
406 (let ((dest-path (compile-file-pathname src-path)))
407 (when (or (not (probe-file dest-path))
408 (newer-file-p src-path dest-path))
409 (ensure-directories-exist dest-path)
410 (compile-file src-path :output-file dest-path))
413 ;;;; implementation of commands
415 (defun apropos-cmd (string)
416 (apropos (string-upcase string))
417 (fresh-line *output*)
420 (let ((last-files-loaded nil))
421 (defun cload-cmd (&optional string-files)
423 (setq last-files-loaded string-files)
424 (setq string-files last-files-loaded))
425 (dolist (arg (string-to-list-skip-spaces string-files))
426 (format *output* "loading ~a~%" arg)
427 (load (compile-file-as-needed arg)))
430 (defun inspect-cmd (arg)
431 (inspector-fun arg nil *output*)
434 (defun istep-cmd (&optional arg-string)
435 (istep (string-to-list-skip-spaces arg-string) *output*)
438 (defun describe-cmd (&rest args)
440 (eval `(describe ,arg)))
443 (defun macroexpand-cmd (arg)
444 (pprint (macroexpand arg) *output*)
447 (defun history-cmd ()
448 (let ((n (length *history*)))
452 (let ((hist (nth (- n i 1) *history*)))
453 (format *output* "~3A " (user-cmd-hnum hist))
454 (if (stringp (user-cmd-input hist))
455 (format *output* "~A~%" (user-cmd-input hist))
456 (format *output* "~W~%" (user-cmd-input hist))))))
459 (defun help-cmd (&optional cmd)
462 (let ((cmd-entry (find-cmd cmd)))
464 (format *output* "Documentation for ~A: ~A~%"
465 (cmd-table-entry-name cmd-entry)
466 (cmd-table-entry-desc cmd-entry)))))
468 (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
469 (format *output* "~11A ~4A ~A~%" "<n>" ""
470 "re-execute <n>th history command")
471 (dolist (doc-entry (get-cmd-doc-list :cmd))
472 (format *output* "~11A ~4A ~A~%" (first doc-entry)
473 (second doc-entry) (third doc-entry)))))
477 (let ((doc-entries (get-cmd-doc-list :alias)))
478 (typecase doc-entries
480 (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
481 (dolist (doc-entry doc-entries)
482 (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
484 (format *output* "No aliases are defined~%"))))
487 (defun shell-cmd (string-arg)
488 (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
489 :input nil :output *output*)
492 (defun pushd-cmd (string-arg)
493 (push string-arg *dir-stack*)
499 (let ((dir (pop *dir-stack*)))
501 (format *output* "No directory on stack to pop.~%"))
504 (defun pop-cmd (&optional (n 1))
507 (throw 'repl-catcher (values :inspect n)))
508 ((plusp *break-level*)
509 (throw 'repl-catcher (values :pop n))))
512 (defun bt-cmd (&optional (n most-positive-fixnum))
513 (sb-debug::backtrace n))
515 (defun current-cmd ()
516 (sb-debug::describe-debug-command))
519 (sb-debug::frame-debug-command 0))
522 (sb-debug::bottom-debug-command))
524 (defun up-cmd (&optional (n 1))
526 (if (and sb-debug::*current-frame*
527 (sb-di:frame-up sb-debug::*current-frame*))
528 (sb-debug::up-debug-command)
530 (format *output* "Top of the stack")
531 (return-from up-cmd)))))
533 (defun dn-cmd (&optional (n 1))
535 (if (and sb-debug::*current-frame*
536 (sb-di:frame-down sb-debug::*current-frame*))
537 (sb-debug::down-debug-command)
539 (format *output* "Bottom of the stack")
540 (return-from dn-cmd)))))
542 (defun continue-cmd (&optional (num 0))
543 ;; don't look at first restart
544 (let ((restarts (compute-restarts)))
549 (if (< -1 num (length restarts))
552 (format *output* "There is no such restart")
553 (return-from continue-cmd))))
555 (find num (the list restarts)
557 :test (lambda (sym1 sym2)
558 (string= (symbol-name sym1)
559 (symbol-name sym2)))))
561 (format *output* "~S is invalid as a restart name" num)
562 (return-from continue-cmd nil)))))
564 (invoke-restart-interactively restart)))
565 (format *output* "~&There are no restarts"))))
568 (when (plusp *break-level*)
570 (sb-debug::show-restarts (compute-restarts) *output*)
571 (let ((sb-debug::*debug-restarts* (compute-restarts)))
572 (sb-debug::error-debug-command)))))
575 (sb-debug::print-frame-call sb-debug::*current-frame*))
580 (defun local-cmd (&optional var)
581 (declare (ignore var))
582 (sb-debug::list-locals-debug-command))
584 (defun processes-cmd ()
586 (let ((pids (thread-pids))
587 (current-pid (sb-thread:current-thread-id)))
589 (format *output* "~&~D" pid)
590 (when (= pid current-pid)
591 (format *output* " [current listener]"))))
593 (format *output* "~&Threads are not supported in this version of sbcl")
596 (defun kill-cmd (&rest selected-pids)
598 (let ((pids (thread-pids)))
599 (dolist (selected-pid selected-pids)
600 (if (find selected-pid pids :test #'eql)
602 (sb-thread:destroy-thread selected-pid)
603 (format *output* "~&Thread ~A destroyed" selected-pid))
604 (format *output* "~&No thread ~A exists" selected-pid))))
606 (declare (ignore selected-pids))
608 (format *output* "~&Threads are not supported in this version of sbcl")
611 (defun signal-cmd (signal &rest selected-pids)
613 (let ((pids (thread-pids)))
614 (dolist (selected-pid selected-pids)
615 (if (find selected-pid pids :test #'eql)
617 (sb-unix:unix-kill selected-pid signal)
618 (format *output* "~&Signal ~A sent to thread ~A"
619 signal selected-pid))
620 (format *output* "~&No thread ~A exists" selected-pid))))
622 (declare (ignore signal selected-pids))
624 (format *output* "~&Threads are not supported in this version of sbcl")
627 (defun focus-cmd (&optional process)
629 (declare (ignore process))
632 (format *output* "~&Focusing on next thread waiting waiting for the debugger~%"))
635 (sb-thread:release-foreground)
638 (format *output* "~&Threads are not supported in this version of sbcl")
642 ;; The last restart goes to the toplevel
643 (invoke-restart-interactively (car (last (compute-restarts)))))
646 (dolist (dir *dir-stack*)
647 (format *output* "~a~%" dir))
651 ;;;; dispatch table for commands
654 '(("aliases" 3 alias-cmd "show aliases")
655 ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
656 ("bottom" 3 bottom-cmd "move to bottom stack frame")
657 ("top" 3 top-cmd "move to top stack frame")
658 ("bt" 2 bt-cmd "backtrace `n' stack frames, default all")
659 ("up" 2 up-cmd "move up `n' stack frames, default 1")
660 ("dn" 2 dn-cmd "move down `n' stack frames, default 1")
661 ("cd" 2 cd-cmd "change default diretory" :parsing :string)
662 ("ld" 2 ld-cmd "load a file" :parsing :string)
663 ("cf" 2 cf-cmd "compile file" :parsing :string)
664 ("cload" 2 cload-cmd "compile if needed and load file"
666 ("current" 3 current-cmd "print the expression for the current stack frame")
667 ("continue" 4 continue-cmd "continue from a continuable error")
668 ("describe" 2 describe-cmd "describe an object")
669 ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
670 ("package" 2 package-cmd "change current package")
671 ("error" 3 error-cmd "print the last error message")
672 ("exit" 2 exit-cmd "exit sbcl")
673 ("frame" 2 frame-cmd "print info about the current frame")
674 ("help" 2 help-cmd "print this help")
675 ("history" 3 history-cmd "print the recent history")
676 ("inspect" 2 inspect-cmd "inspect an object")
677 ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
678 #+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes")
679 #+sb-thread ("signal" 2 signal-cmd "send a signal to processes")
680 #+sb-thread ("focus" 2 focus-cmd "focus the top level on a process")
681 ("local" 3 local-cmd "print the value of a local variable")
682 ("pwd" 3 pwd-cmd "print current directory")
683 ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
684 ("pop" 3 pop-cmd "pop up `n' (default 1) break levels")
685 ("popd" 4 popd-cmd "pop directory from stack")
686 #+sb-thread ("processes" 3 processes-cmd "list all processes")
687 ("reset" 3 reset-cmd "reset to top break level")
688 ("trace" 2 trace-cmd "trace a function")
689 ("untrace" 4 untrace-cmd "untrace a function")
690 ("dirs" 2 dirs-cmd "show directory stack")
691 ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string)
692 ("zoom" 2 zoom-cmd "print the runtime stack")
694 (dolist (cmd cmd-table)
695 (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
696 (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
698 ;;;; machinery for aliases
700 (defsetf alias (name &key abbr-len description) (user-func)
703 (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len))
706 (defmacro alias (name-param args &rest body)
710 (name (if (atom name-param)
713 (when (consp name-param)
714 (dolist (param (cdr name-param))
717 (eq param :case-sensitive)
719 (setq parsing param))
723 (setq abbr-index param)))))
726 (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index
732 (defun remove-alias (&rest aliases)
733 (declare (list aliases))
735 (remove-all (not (null (find :all aliases)))))
736 (unless remove-all ;; ensure all alias are strings
738 (loop for alias in aliases
744 (symbol-name alias))))))
747 (when (eq (cmd-table-entry-group cmd) :alias)
752 (let ((klen (length key)))
753 (and (>= (length alias) klen)
754 (string-equal (subseq alias 0 klen)
755 (subseq key 0 klen)))))
760 (remhash key *cmd-table-hash*))
763 ;;;; low-level reading/parsing functions
765 ;;; Skip white space (but not #\NEWLINE), and peek at the next
767 (defun peek-char-non-whitespace (&optional stream)
768 (do ((char (peek-char nil stream nil *eof-marker*)
769 (peek-char nil stream nil *eof-marker*)))
770 ((not (whitespace-char-not-newline-p char)) char)
773 (defun string-trim-whitespace (str)
774 (string-trim '(#\space #\tab #\return)
777 (defun whitespace-char-p (x)
779 (or (char= x #\space)
782 (char= x #\return))))
784 (defun whitespace-char-not-newline-p (x)
785 (and (whitespace-char-p x)
786 (not (char= x #\newline))))
789 ;;;; linking into SBCL hooks
792 (defun repl-prompt-fun (stream)
793 (let ((break-level (when (plusp *break-level*)
795 (frame-number (when (and (plusp *break-level*)
796 sb-debug::*current-frame*)
797 (sb-di::frame-number sb-debug::*current-frame*))))
799 (let ((lock sb-thread::*session-lock*))
800 (sb-thread::get-foreground)
801 (let ((stopped-threads (sb-thread::waitqueue-data lock)))
802 (when stopped-threads
803 (format stream "~{~&Thread ~A suspended~}~%" stopped-threads))))
805 (if (functionp *prompt*)
806 (write-string (funcall *prompt*
811 (prompt-package-name) *cmd-number*)
819 (prompt-package-name) *cmd-number*)
821 (format stream "~&Prompt error> "))
823 (format stream "~A" prompt))))))
825 (defun process-cmd (user-cmd)
826 ;; Processes a user command. Returns t if the user-cmd was a top-level
828 (cond ((eq user-cmd *eof-cmd*)
831 (format *output* "EOF~%")
833 ((eq user-cmd *null-cmd*)
835 ((eq (user-cmd-func user-cmd) :cmd-error)
836 (format *output* "Unknown top-level command: ~s.~%"
837 (user-cmd-input user-cmd))
838 (format *output* "Type `:help' for the list of commands.~%")
840 ((eq (user-cmd-func user-cmd) :history-error)
841 (format *output* "Input numbered ~d is not on the history list~%"
842 (user-cmd-input user-cmd))
844 ((functionp (user-cmd-func user-cmd))
845 (add-to-history user-cmd)
846 (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd))
850 (add-to-history user-cmd)
851 nil))) ; nope, not in my job description
853 (defun repl-read-form-fun (input output)
854 ;; Pick off all the leading ACL magic commands, then return a normal
856 (let ((*input* input)
858 (loop for user-cmd = (read-cmd *input*) do
859 (if (process-cmd user-cmd)
861 (funcall sb-int:*repl-prompt-fun* *output*)
862 (force-output *output*))
863 (return (user-cmd-input user-cmd))))))
866 (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
867 sb-int:*repl-read-form-fun* #'repl-read-form-fun)
869 ) ;; close special variables bindings