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:defpackage
:sb-aclrepl
12 (:export
#:*prompt
* #:*exit-on-eof
* #:*max-history
*
13 #:*use-short-package-name
* #:*command-char
*
16 (cl:in-package
:sb-aclrepl
)
19 (input nil
) ; input, maybe a string or form
20 (func nil
) ; cmd func entered, overloaded
21 ; (:eof :null-cmd :cmd-error :history-error)
22 (args nil
) ; args for cmd func
23 (hnum nil
)) ; history number
26 ;; numeric break level
28 ;; inspect data for a break level
30 ;; T when break initiated by an inspect
32 ;; restarts list for a break level
34 ;; T if break level is a continuable break
38 (defstruct cmd-table-entry
39 (name nil
) ; name of command
40 (func nil
) ; function handler
41 (desc nil
) ; short description
42 (parsing nil
) ; (:string :case-sensitive nil)
43 (group nil
) ; command group (:cmd or :alias)
44 (abbr-len 0)) ; abbreviation length
46 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
47 (defparameter *default-prompt
* "~:[~2*~;[~:*~D~:[~;i~]~:[~;c~]] ~]~A(~D): "
48 "The default prompt."))
49 (defparameter *prompt
* #.
*default-prompt
*
50 "The current prompt string or formatter function.")
51 (defparameter *use-short-package-name
* t
52 "when T, use the shortnest package nickname in a prompt")
53 (defparameter *dir-stack
* nil
54 "The top-level directory stack")
55 (defparameter *command-char
* #\
:
56 "Prefix character for a top-level command")
57 (defvar *max-history
* 24
58 "Maximum number of history commands to remember")
59 (defvar *exit-on-eof
* t
60 "If T, then exit when the EOF character is entered.")
61 (defparameter *history
* nil
63 (defparameter *cmd-number
* 1
64 "Number of the next command")
65 (defparameter *repl-output
* nil
66 "The output stream for the repl")
67 (defparameter *repl-input
* nil
68 "The input stream for the repl")
69 (defparameter *break-stack
* (list (make-break-data :level
0))
70 "A stack of break data stored as a list of break-level structs")
72 (declaim (type list
*history
*))
74 (defvar *eof-marker
* :eof
)
75 (defvar *eof-cmd
* (make-user-cmd :func
:eof
))
76 (defvar *null-cmd
* (make-user-cmd :func
:null-cmd
))
78 (defparameter *cmd-table-hash
*
79 (make-hash-table :size
30 :test
#'equal
))
81 ;; Set up binding for multithreading
83 (let ((*prompt
* #.
*default-prompt
*)
84 (*use-short-package-name
* t
)
93 (*break-stack
* (list (make-break-data :level
0)))
96 (defun prompt-package-name ()
97 (if *use-short-package-name
*
99 (package-nicknames cl
:*package
*)
100 (list (package-name cl
:*package
*)))
101 (lambda (a b
) (< (length a
) (length b
)))))
102 (package-name cl
:*package
*)))
104 (defun read-cmd (input-stream)
105 ;; Reads a command from the user and returns a user-cmd object
106 (flet ((parse-args (parsing args-string
)
109 (if (zerop (length args-string
))
113 (let ((string-stream (make-string-input-stream args-string
))
114 (eof (cons nil
*eof-marker
*))) ;new cons for eq uniqueness
115 (loop as arg
= (read string-stream nil eof
)
118 (let ((next-char (peek-char-non-whitespace input-stream
)))
120 ((eql next-char
*command-char
*)
121 (let* ((line (string-trim-whitespace (read-line input-stream
)))
122 (first-space-pos (position #\space line
))
123 (cmd-string (subseq line
1 first-space-pos
))
126 (string-trim-whitespace (subseq line first-space-pos
))
128 (declare (string line
))
129 (if (numberp (read-from-string cmd-string
))
130 (let ((cmd (get-history (read-from-string cmd-string
))))
131 (if (eq cmd
*null-cmd
*)
132 (make-user-cmd :func
:history-error
133 :input
(read-from-string cmd-string
))
134 (make-user-cmd :func
(user-cmd-func cmd
)
135 :input
(user-cmd-input cmd
)
136 :args
(user-cmd-args cmd
)
137 :hnum
*cmd-number
*)))
138 (let ((cmd-entry (find-cmd cmd-string
)))
140 (make-user-cmd :func
(cmd-table-entry-func cmd-entry
)
143 (cmd-table-entry-parsing cmd-entry
)
146 (make-user-cmd :func
:cmd-error
149 ((eql next-char
#\newline
)
150 (read-char input-stream
)
153 (let* ((eof (cons nil
*eof-marker
*))
154 (form (read input-stream nil eof
)))
157 (make-user-cmd :input form
:func nil
:hnum
*cmd-number
*))))))))
159 (defun make-cte (name-param func desc parsing group abbr-len
)
160 (let ((name (etypecase name-param
164 (string-downcase (write-to-string name-param
))))))
165 (make-cmd-table-entry :name name
:func func
:desc desc
166 :parsing parsing
:group group
167 :abbr-len
(if abbr-len
171 (defun %add-entry
(cmd &optional abbr-len
)
172 (let* ((name (cmd-table-entry-name cmd
))
176 (dotimes (i (length name
))
177 (when (>= i
(1- alen
))
178 (setf (gethash (subseq name
0 (1+ i
)) *cmd-table-hash
*)
181 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing
)
183 (make-cte cmd-string
(symbol-function func-name
) desc parsing
:cmd abbr-len
)
186 (defun find-cmd (cmdstr)
187 (gethash (string-downcase cmdstr
) *cmd-table-hash
*))
189 (defun user-cmd= (c1 c2
)
190 "Returns T if two user commands are equal"
191 (and (eq (user-cmd-func c1
) (user-cmd-func c2
))
192 (equal (user-cmd-args c1
) (user-cmd-args c2
))
193 (equal (user-cmd-input c1
) (user-cmd-input c2
))))
195 (defun add-to-history (cmd)
196 (unless (and *history
* (user-cmd= cmd
(car *history
*)))
197 (when (>= (length *history
*) *max-history
*)
198 (setq *history
* (nbutlast *history
* (+ (length *history
*) *max-history
* 1))))
200 (incf *cmd-number
*)))
202 (defun get-history (n)
203 (let ((cmd (find n
*history
* :key
#'user-cmd-hnum
:test
#'eql
)))
208 (defun get-cmd-doc-list (&optional
(group :cmd
))
209 "Return list of all commands"
211 (maphash (lambda (k v
)
213 (= (length k
) (length (cmd-table-entry-name v
)))
214 (eq (cmd-table-entry-group v
) group
))
216 (if (= (cmd-table-entry-abbr-len v
)
219 (subseq k
0 (cmd-table-entry-abbr-len v
)))
220 (cmd-table-entry-desc v
)) cmds
)))
222 (sort cmds
#'string-lessp
:key
#'car
)))
224 (defun cd-cmd (&optional string-dir
)
226 ((or (zerop (length string-dir
))
227 (string= string-dir
"~"))
228 (setf cl
:*default-pathname-defaults
* (user-homedir-pathname)))
230 (let ((new (truename string-dir
)))
231 (when (pathnamep new
)
232 (setf cl
:*default-pathname-defaults
* new
)))))
233 (format *repl-output
* "~A~%" (namestring cl
:*default-pathname-defaults
*))
237 (format *repl-output
* "Lisp's current working directory is ~s.~%"
238 (namestring cl
:*default-pathname-defaults
*))
241 (defun trace-cmd (&rest args
)
243 (format *repl-output
* "~A~%" (eval (sb-debug::expand-trace args
)))
244 (format *repl-output
* "~A~%" (sb-debug::%list-traced-funs
)))
247 (defun untrace-cmd (&rest args
)
249 (format *repl-output
* "~A~%"
251 (sb-int:collect
((res))
252 (let ((current args
))
254 (unless current
(return))
255 (let ((name (pop current
)))
256 (res (if (eq name
:function
)
257 `(sb-debug::untrace-1
,(pop current
))
258 `(sb-debug::untrace-1
',name
))))))
259 `(progn ,@(res) t
))))
260 (format *repl-output
* "~A~%" (eval (sb-debug::untrace-all
))))
264 (defun thread-pids ()
265 "Return a list of the pids for all threads"
266 (let ((offset (* 4 sb-vm
::thread-pid-slot
)))
267 (sb-thread::mapcar-threads
268 #'(lambda (sap) (sb-sys:sap-ref-32 sap offset
)))))
271 (defun other-thread-pids ()
272 "Returns a list of pids for all threads except the current process"
273 (delete (sb-thread:current-thread-id
) (thread-pids) :test
#'eql
))
275 (defun exit-cmd (&optional
(status 0))
277 (let ((other-pids (other-thread-pids)))
279 (format *repl-output
* "There exists the following processes~%")
280 (format *repl-output
* "~{~5d~%~}" other-pids
)
281 (format *repl-output
* "Do you want to exit lisp anyway [n]? ")
282 (force-output *repl-output
*)
283 (let ((input (string-trim-whitespace (read-line *repl-input
*))))
284 (if (and (plusp (length input
))
285 (or (char= #\y
(char input
0))
286 (char= #\Y
(char input
0))))
287 ;; loop in case more threads get created while trying to exit
288 (do ((pids other-pids
(other-thread-pids)))
290 (map nil
#'sb-thread
:destroy-thread pids
)
292 (return-from exit-cmd
)))))
293 (quit :unix-status status
)
296 (defun package-cmd (&optional pkg
)
299 (format *repl-output
* "The ~A package is current.~%"
300 (package-name cl
:*package
*)))
301 ((null (find-package (write-to-string pkg
)))
302 (format *repl-output
* "Unknown package: ~A.~%" pkg
))
304 (setf cl
:*package
* (find-package (write-to-string pkg
)))))
307 (defun string-to-list-skip-spaces (str)
308 "Return a list of strings, delimited by spaces, skipping spaces."
309 (declare (type (or null string
) str
))
311 (loop for i
= 0 then
(1+ j
)
312 as j
= (position #\space str
:start i
)
313 when
(not (char= (char str i
) #\space
))
314 collect
(subseq str i j
) while j
)))
316 (let ((last-files-loaded nil
))
317 (defun ld-cmd (&optional string-files
)
319 (setq last-files-loaded string-files
)
320 (setq string-files last-files-loaded
))
321 (dolist (arg (string-to-list-skip-spaces string-files
))
323 (if (string= arg
"~/" :end1
1 :end2
1)
324 (merge-pathnames (parse-namestring
325 (string-left-trim "~/" arg
))
326 (user-homedir-pathname))
328 (format *repl-output
* "loading ~S~%" file
)
332 (defun cf-cmd (string-files)
334 (dolist (arg (string-to-list-skip-spaces string-files
))
339 "Return if x and y are numbers, and x > y"
340 (and (numberp x
) (numberp y
) (> x y
)))
342 (defun newer-file-p (file1 file2
)
343 "Is file1 newer (written later than) file2?"
344 (>-num
(if (probe-file file1
) (file-write-date file1
))
345 (if (probe-file file2
) (file-write-date file2
))))
347 (defun compile-file-as-needed (src-path)
348 "Compiles a file if needed, returns path."
349 (let ((dest-path (compile-file-pathname src-path
)))
350 (when (or (not (probe-file dest-path
))
351 (newer-file-p src-path dest-path
))
352 (ensure-directories-exist dest-path
)
353 (compile-file src-path
:output-file dest-path
))
356 ;;;; implementation of commands
358 (defun apropos-cmd (string)
359 (apropos (string-upcase string
))
362 (let ((last-files-loaded nil
))
363 (defun cload-cmd (&optional string-files
)
365 (setq last-files-loaded string-files
)
366 (setq string-files last-files-loaded
))
367 (dolist (arg (string-to-list-skip-spaces string-files
))
368 (format *repl-output
* "loading ~a~%" arg
)
369 (load (compile-file-as-needed arg
)))
372 (defun inspect-cmd (arg)
373 (inspector arg nil
*repl-output
*)
376 (defun istep-cmd (&optional arg-string
)
377 (istep (string-to-list-skip-spaces arg-string
) *repl-output
*)
380 (defun describe-cmd (&rest args
)
382 (eval `(describe ,arg
)))
385 (defun macroexpand-cmd (arg)
386 (pprint (macroexpand arg
) *repl-output
*)
389 (defun history-cmd ()
390 (let ((n (length *history
*)))
394 (let ((hist (nth (- n i
1) *history
*)))
395 (format *repl-output
* "~3A " (user-cmd-hnum hist
))
396 (if (stringp (user-cmd-input hist
))
397 (format *repl-output
* "~A~%" (user-cmd-input hist
))
398 (format *repl-output
* "~W~%" (user-cmd-input hist
))))))
401 (defun help-cmd (&optional cmd
)
404 (let ((cmd-entry (find-cmd cmd
)))
406 (format *repl-output
* "Documentation for ~A: ~A~%"
407 (cmd-table-entry-name cmd-entry
)
408 (cmd-table-entry-desc cmd-entry
)))))
410 (format *repl-output
* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
411 (format *repl-output
* "~11A ~4A ~A~%" "<n>" ""
412 "re-execute <n>th history command")
413 (dolist (doc-entry (get-cmd-doc-list :cmd
))
414 (format *repl-output
* "~11A ~4A ~A~%" (first doc-entry
)
415 (second doc-entry
) (third doc-entry
)))))
419 (let ((doc-entries (get-cmd-doc-list :alias
)))
420 (typecase doc-entries
422 (format *repl-output
* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
423 (dolist (doc-entry doc-entries
)
424 (format *repl-output
* "~11A ~4A ~A~%" (first doc-entry
) (second doc-entry
) (third doc-entry
))))
426 (format *repl-output
* "No aliases are defined~%"))))
429 (defun shell-cmd (string-arg)
430 (sb-ext:run-program
"/bin/sh" (list "-c" string-arg
)
431 :input nil
:output
*repl-output
*)
434 (defun pushd-cmd (string-arg)
435 (push string-arg
*dir-stack
*)
436 (cd-cmd *repl-output
* string-arg
)
441 (let ((dir (pop *dir-stack
*)))
443 (format *repl-output
* "No directory on stack to pop.~%"))
446 (defun pop-cmd (&optional
(n 1))
447 (let ((new-level (- (length *break-stack
*) n
1)))
448 (when (minusp new-level
)
450 (dotimes (i (- (length *break-stack
*) new-level
1))
451 (pop *break-stack
*)))
453 (do* ((i (1- (length *break-stack
*)) (1- i
))
455 ((or found
(minusp i
)))
456 (let ((inspect (break-data-inspect (nth i
*break-stack
*))))
458 (set-current-inspect inspect
)
462 (defun continue-cmd (n)
463 (let ((restarts (break-data-restarts (car *break-stack
*))))
465 (if (< -
1 n
(length restarts
))
467 (invoke-restart-interactively (nth n restarts
))
469 (format *repl-output
* "~&There is no such restart"))
470 (format *repl-output
* "~&There are no restarts"))))
475 (defun current-cmd ()
484 (defun local-cmd (&optional var
)
485 (declare (ignore var
))
488 (defun processes-cmd ()
490 (let ((pids (thread-pids))
491 (current-pid (sb-thread:current-thread-id
)))
493 (format *repl-output
* "~&~D" pid
)
494 (when (= pid current-pid
)
495 (format *repl-output
* " [current listener]"))))
497 (format *repl-output
* "~&Threads are not supported in this version of sbcl")
500 (defun kill-cmd (&rest selected-pids
)
502 (let ((pids (thread-pids)))
503 (dolist (selected-pid selected-pids
)
504 (if (find selected-pid pids
:test
#'eql
)
506 (sb-thread:destroy-thread selected-pid
)
507 (format *repl-output
* "~&Thread ~A destroyed" selected-pid
))
508 (format *repl-output
* "~&No thread ~A exists" selected-pid
))))
510 (declare (ignore selected-pids
))
512 (format *repl-output
* "~&Threads are not supported in this version of sbcl")
515 (defun signal-cmd (signal &rest selected-pids
)
517 (let ((pids (thread-pids)))
518 (dolist (selected-pid selected-pids
)
519 (if (find selected-pid pids
:test
#'eql
)
521 (sb-unix:unix-kill selected-pid signal
)
522 (format *repl-output
* "~&Signal ~A sent to thread ~A"
523 signal selected-pid
))
524 (format *repl-output
* "~&No thread ~A exists" selected-pid
))))
526 (declare (ignore signal selected-pids
))
528 (format *repl-output
* "~&Threads are not supported in this version of sbcl")
531 (defun focus-cmd (&optional process
)
533 (declare (ignore process
))
536 (format *repl-output
* "~&Focusing on next thread waiting waiting for the debugger~%"))
539 (sb-thread:release-foreground
)
542 (format *repl-output
* "~&Threads are not supported in this version of sbcl")
546 (setf *break-stack
* (last *break-stack
*))
550 (dolist (dir *dir-stack
*)
551 (format *repl-output
* "~a~%" dir
))
555 ;;;; dispatch table for commands
558 '(("aliases" 3 alias-cmd
"show aliases")
559 ("apropos" 2 apropos-cmd
"show apropos" :parsing
:string
)
560 ("cd" 2 cd-cmd
"change default diretory" :parsing
:string
)
561 ("ld" 2 ld-cmd
"load a file" :parsing
:string
)
562 ("cf" 2 cf-cmd
"compile file" :parsing
:string
)
563 ("cload" 2 cload-cmd
"compile if needed and load file"
565 #+aclrepl-debugger
("current" 3 current-cmd
"print the expression for the current stack frame")
566 #+aclrepl-debugger
("continue" 4 continue-cmd
"continue from a continuable error")
567 ("describe" 2 describe-cmd
"describe an object")
568 ("macroexpand" 2 macroexpand-cmd
"macroexpand an expression")
569 ("package" 2 package-cmd
"change current package")
570 #+aclrepl-debugger
("error" 3 error-cmd
"print the last error message")
571 ("exit" 2 exit-cmd
"exit sbcl")
572 #+aclrepl-debugger
("frame" 2 frame-cmd
"print info about the current frame")
573 ("help" 2 help-cmd
"print this help")
574 ("history" 3 history-cmd
"print the recent history")
575 ("inspect" 2 inspect-cmd
"inspect an object")
576 ("istep" 1 istep-cmd
"navigate within inspection of a lisp object" :parsing
:string
)
577 #+sb-thread
("kill" 2 kill-cmd
"kill (destroy) processes")
578 #+sb-thread
("signal" 2 signal-cmd
"send a signal to processes")
579 #+sb-thread
("focus" 2 focus-cmd
"focus the top level on a process")
580 #+aclrepl-debugger
("local" 3 local-cmd
"print the value of a local variable")
581 ("pwd" 3 pwd-cmd
"print current directory")
582 ("pushd" 2 pushd-cmd
"push directory on stack" :parsing
:string
)
583 ("pop" 3 pop-cmd
"pop up `n' (default 1) break levels")
584 ("popd" 4 popd-cmd
"pop directory from stack")
585 #+sb-thread
("processes" 3 processes-cmd
"list all processes")
586 ("reset" 3 reset-cmd
"reset to top break level")
587 ("trace" 2 trace-cmd
"trace a function")
588 ("untrace" 4 untrace-cmd
"untrace a function")
589 ("dirs" 2 dirs-cmd
"show directory stack")
590 ("shell" 2 shell-cmd
"execute a shell cmd" :parsing
:string
)
591 #+aclrepl-debugger
("zoom" 2 zoom-cmd
"print the runtime stack")
593 (dolist (cmd cmd-table
)
594 (destructuring-bind (cmd-string abbr-len func-name desc
&key parsing
) cmd
595 (add-cmd-table-entry cmd-string abbr-len func-name desc parsing
))))
597 ;;;; machinery for aliases
599 (defsetf alias
(name &key abbr-len description
) (user-func)
602 (make-cte (quote ,name
) ,user-func
,description nil
:alias
,abbr-len
))
605 (defmacro alias
(name-param args
&rest body
)
609 (name (if (atom name-param
)
612 (when (consp name-param
)
613 (dolist (param (cdr name-param
))
616 (eq param
:case-sensitive
)
618 (setq parsing param
))
622 (setq abbr-index param
)))))
625 (make-cte (quote ,name
) (lambda ,args
,@body
) ,desc
,parsing
:alias
(when ,abbr-index
631 (defun remove-alias (&rest aliases
)
632 (declare (list aliases
))
634 (remove-all (not (null (find :all aliases
)))))
635 (unless remove-all
;; ensure all alias are strings
637 (loop for alias in aliases
643 (symbol-name alias
))))))
646 (when (eq (cmd-table-entry-group cmd
) :alias
)
651 (let ((klen (length key
)))
652 (and (>= (length alias
) klen
)
653 (string-equal (subseq alias
0 klen
)
654 (subseq key
0 klen
)))))
659 (remhash key
*cmd-table-hash
*))
662 ;;;; low-level reading/parsing functions
664 ;;; Skip white space (but not #\NEWLINE), and peek at the next
666 (defun peek-char-non-whitespace (&optional stream
)
667 (do ((char (peek-char nil stream nil
*eof-marker
*)
668 (peek-char nil stream nil
*eof-marker
*)))
669 ((not (whitespace-char-not-newline-p char
)) char
)
672 (defun string-trim-whitespace (str)
673 (string-trim '(#\space
#\tab
#\return
)
676 (defun whitespace-char-not-newline-p (x)
678 (or (char= x
#\space
)
680 (char= x
#\return
))))
683 ;;;; linking into SBCL hooks
686 (defun repl-prompt-fun (stream)
687 (let* ((break-data (car *break-stack
*))
688 (break-level (break-data-level break-data
)))
689 (when (zerop break-level
)
690 (setq break-level nil
))
692 (let ((lock sb-thread
::*session-lock
*))
693 (sb-thread::get-foreground
)
694 (let ((stopped-threads (sb-thread::waitqueue-data lock
)))
695 (when stopped-threads
696 (format stream
"~{~&Thread ~A suspended~}~%" stopped-threads
))))
697 (if (functionp *prompt
*)
698 (write-string (funcall *prompt
* break-level
699 (break-data-inspect-initiated break-data
)
700 (break-data-continuable break-data
)
701 (prompt-package-name) *cmd-number
*)
704 (format nil
*prompt
* break-level
705 (break-data-inspect-initiated break-data
)
706 (break-data-continuable break-data
)
707 (prompt-package-name) *cmd-number
*)
709 (format stream
"~&Prompt error> "))
711 (format stream
"~&~A" prompt
))))))
713 (defun process-cmd (user-cmd input-stream output-stream
)
714 ;; Processes a user command. Returns t if the user-cmd was a top-level
716 (cond ((eq user-cmd
*eof-cmd
*)
719 (format output-stream
"EOF~%")
721 ((eq user-cmd
*null-cmd
*)
723 ((eq (user-cmd-func user-cmd
) :cmd-error
)
724 (format output-stream
"Unknown top-level command: ~s.~%"
725 (user-cmd-input user-cmd
))
726 (format output-stream
"Type `:help' for the list of commands.~%")
728 ((eq (user-cmd-func user-cmd
) :history-error
)
729 (format output-stream
"Input numbered ~d is not on the history list~%"
730 (user-cmd-input user-cmd
))
732 ((functionp (user-cmd-func user-cmd
))
733 (add-to-history user-cmd
)
734 (let ((*repl-output
* output-stream
)
735 (*repl-input
* input-stream
))
736 (apply (user-cmd-func user-cmd
) (user-cmd-args user-cmd
)))
740 (add-to-history user-cmd
)
741 nil
))) ; nope, not in my job description
743 (defun repl-read-form-fun (input-stream output-stream
)
744 ;; Pick off all the leading ACL magic commands, then return a normal
746 (loop for user-cmd
= (read-cmd input-stream
) do
747 (if (process-cmd user-cmd input-stream output-stream
)
749 (funcall sb-int
:*repl-prompt-fun
* output-stream
)
750 (force-output output-stream
))
751 (return (user-cmd-input user-cmd
)))))
754 (setf sb-int
:*repl-prompt-fun
* #'repl-prompt-fun
755 sb-int
:*repl-read-form-fun
* #'repl-read-form-fun
)
757 ;;; Break level processing
759 ;; use an initial break-level to hold current inspect toplevel at
762 (defun new-break (&key restarts inspect continuable
)
764 (make-break-data :level
(length *break-stack
*)
767 :inspect-initiated
(when inspect t
)
768 :continuable continuable
)
771 (defun set-break-inspect (inspect)
772 "sets the inspect data for the current break level"
773 (setf (break-data-inspect (car *break-stack
*)) inspect
))
775 ) ;; close special variables bindings