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 (defvar *eof-marker
* :eof
)
56 (defvar *eof-cmd
* (make-user-cmd :func
:eof
))
57 (defvar *null-cmd
* (make-user-cmd :func
:null-cmd
))
59 (defparameter *cmd-table-hash
*
60 (make-hash-table :size
30 :test
#'equal
))
62 (defun prompt-package-name ()
63 (if *use-short-package-name
*
65 (package-nicknames cl
:*package
*)
66 (list (package-name cl
:*package
*)))
67 (lambda (a b
) (< (length a
) (length b
)))))
68 (package-name cl
:*package
*)))
70 (defun read-cmd (input-stream)
71 ;; Reads a command from the user and returns a user-cmd object
72 (let* ((next-char (peek-char-non-whitespace input-stream
))
74 ((eql *command-char
* next-char
)
75 (dispatch-command-line input-stream
))
76 ((eql #\newline next-char
)
77 (read-char input-stream
)
82 (let* ((eof (cons nil
*eof-marker
*))
83 (form (read input-stream nil eof
)))
86 (make-user-cmd :input form
:func nil
:hnum
*cmd-number
*)))))))
87 (if (and (eq cmd
*eof-cmd
*) (typep input-stream
'string-stream
))
88 (throw 'repl-catcher cmd
)
91 (defun dispatch-command-line (input-stream)
92 "Processes an input line that starts with *command-char*"
93 (let* ((line (string-trim-whitespace (read-line input-stream
)))
94 (first-space-pos (position #\space line
))
95 (cmd-string (subseq line
1 first-space-pos
))
98 (string-trim-whitespace (subseq line first-space-pos
))
100 (declare (simple-string line
))
102 ((or (zerop (length cmd-string
))
103 (whitespace-char-p (char cmd-string
0)))
105 ((or (numberp (read-from-string cmd-string
))
106 (char= (char cmd-string
0) #\
+)
107 (char= (char cmd-string
0) #\-
))
108 (process-cmd-numeric cmd-string cmd-args-string
))
109 ((char= (char cmd-string
0) *command-char
*)
110 (process-history-search (subseq cmd-string
1) cmd-args-string
))
112 (process-cmd-text cmd-string line cmd-args-string
)))))
114 (defun process-cmd-numeric (cmd-string cmd-args-string
)
115 "Process a numeric cmd, such as ':123'"
116 (let* ((first-char (char cmd-string
0))
117 (number-string (if (digit-char-p first-char
)
119 (subseq cmd-string
1)))
120 (is-minus (char= first-char
#\-
))
121 (raw-number (read-from-string number-string
))
123 (- *cmd-number
* raw-number
)
125 (cmd (get-history number
)))
126 (when (eq cmd
*null-cmd
*)
127 (return-from process-cmd-numeric
128 (make-user-cmd :func
:history-error
:input
(read-from-string
130 (maybe-return-history-cmd cmd cmd-args-string
)))
132 (defun maybe-return-history-cmd (cmd cmd-args-string
)
133 (format *output
* "~A~%" (user-cmd-input cmd
))
135 (when (and (stringp cmd-args-string
)
136 (plusp (length cmd-args-string
))
137 (char= #\? (char cmd-args-string
0)))
138 (do ((line nil
(read-line *input
*)))
139 ((and line
(or (zerop (length line
))
140 (string-equal line
"Y")
141 (string-equal line
"N")))
142 (when (string-equal line
"N")
145 (format *output
* "Type \"y\" for yes or \"n\" for no.~%"))
146 (format *output
* "redo? [y] ")
147 (force-output *output
*)))))
150 (make-user-cmd :func
(user-cmd-func cmd
)
151 :input
(user-cmd-input cmd
)
152 :args
(user-cmd-args cmd
)
153 :hnum
*cmd-number
*))))
156 (defun find-history-matching-pattern (cmd-string)
157 "Return history item matching cmd-string or NIL if not found"
158 (dolist (his *history
* nil
)
159 (let* ((input (user-cmd-input his
))
160 (string-input (if (stringp input
)
162 (write-to-string input
))))
163 (when (search cmd-string string-input
:test
#'string-equal
)
164 (return-from find-history-matching-pattern his
)))))
166 (defun process-history-search (pattern cmd-args-string
)
167 (let ((cmd (find-history-matching-pattern pattern
)))
169 (format *output
* "No match on history list with pattern ~S~%" pattern
)
170 (return-from process-history-search
*null-cmd
*))
171 (maybe-return-history-cmd cmd cmd-args-string
)))
174 (defun process-cmd-text (cmd-string line cmd-args-string
)
175 "Process a text cmd, such as ':ld a b c'"
176 (flet ((parse-args (parsing args-string
)
179 (if (zerop (length args-string
))
183 (let ((string-stream (make-string-input-stream args-string
))
184 (eof (cons nil
*eof-marker
*))) ;new cons for eq uniqueness
185 (loop as arg
= (read string-stream nil eof
)
188 (let ((cmd-entry (find-cmd cmd-string
)))
190 (return-from process-cmd-text
191 (make-user-cmd :func
:cmd-error
:input cmd-string
)))
192 (make-user-cmd :func
(cmd-table-entry-func cmd-entry
)
194 :args
(parse-args (cmd-table-entry-parsing cmd-entry
)
196 :hnum
*cmd-number
*))))
198 (defun make-cte (name-param func desc parsing group abbr-len
)
199 (let ((name (etypecase name-param
203 (string-downcase (write-to-string name-param
))))))
204 (make-cmd-table-entry :name name
:func func
:desc desc
205 :parsing parsing
:group group
206 :abbr-len
(if abbr-len
210 (defun %add-entry
(cmd &optional abbr-len
)
211 (let* ((name (cmd-table-entry-name cmd
))
215 (dotimes (i (length name
))
216 (when (>= i
(1- alen
))
217 (setf (gethash (subseq name
0 (1+ i
)) *cmd-table-hash
*)
220 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing
)
222 (make-cte cmd-string
(symbol-function func-name
) desc parsing
:cmd abbr-len
)
225 (defun find-cmd (cmdstr)
226 (gethash (string-downcase cmdstr
) *cmd-table-hash
*))
228 (defun user-cmd= (c1 c2
)
229 "Returns T if two user commands are equal"
230 (and (eq (user-cmd-func c1
) (user-cmd-func c2
))
231 (equal (user-cmd-args c1
) (user-cmd-args c2
))
232 (equal (user-cmd-input c1
) (user-cmd-input c2
))))
234 (defun add-to-history (cmd)
235 (unless (and *history
* (user-cmd= cmd
(car *history
*)))
236 (when (>= (length *history
*) *max-history
*)
237 (setq *history
* (nbutlast *history
*
238 (1+ (- (length *history
*) *max-history
*)))))
240 (incf *cmd-number
*)))
242 (defun get-history (n)
243 (let ((cmd (find n
*history
* :key
#'user-cmd-hnum
:test
#'eql
)))
248 (defun get-cmd-doc-list (&optional
(group :cmd
))
249 "Return list of all commands"
251 (maphash (lambda (k v
)
253 (= (length k
) (length (cmd-table-entry-name v
)))
254 (eq (cmd-table-entry-group v
) group
))
256 (if (= (cmd-table-entry-abbr-len v
)
259 (subseq k
0 (cmd-table-entry-abbr-len v
)))
260 (cmd-table-entry-desc v
)) cmds
)))
262 (sort cmds
#'string-lessp
:key
#'car
)))
264 (defun cd-cmd (&optional string-dir
)
266 ((or (zerop (length string-dir
))
267 (string= string-dir
"~"))
268 (setf cl
:*default-pathname-defaults
* (user-homedir-pathname)))
270 (let ((new (truename string-dir
)))
271 (when (pathnamep new
)
272 (setf cl
:*default-pathname-defaults
* new
)))))
273 (format *output
* "~A~%" (namestring cl
:*default-pathname-defaults
*))
277 (format *output
* "Lisp's current working directory is ~s.~%"
278 (namestring cl
:*default-pathname-defaults
*))
281 (defun trace-cmd (&rest args
)
283 (format *output
* "~A~%" (eval (sb-debug::expand-trace args
)))
284 (format *output
* "~A~%" (sb-debug::%list-traced-funs
)))
287 (defun untrace-cmd (&rest args
)
289 (format *output
* "~A~%"
291 (sb-int:collect
((res))
292 (let ((current args
))
294 (unless current
(return))
295 (let ((name (pop current
)))
296 (res (if (eq name
:function
)
297 `(sb-debug::untrace-1
,(pop current
))
298 `(sb-debug::untrace-1
',name
))))))
299 `(progn ,@(res) t
))))
300 (format *output
* "~A~%" (eval (sb-debug::untrace-all
))))
304 (defun thread-pids ()
305 "Return a list of the pids for all threads"
306 (let ((offset (* 4 sb-vm
::thread-pid-slot
)))
307 (sb-thread::mapcar-threads
308 #'(lambda (sap) (sb-sys:sap-ref-32 sap offset
)))))
311 (defun other-thread-pids ()
312 "Returns a list of pids for all threads except the current process"
313 (delete (sb-thread:current-thread-id
) (thread-pids) :test
#'eql
))
315 (defun exit-cmd (&optional
(status 0))
317 (let ((other-pids (other-thread-pids)))
319 (format *output
* "There exists the following processes~%")
320 (format *output
* "~{~5d~%~}" other-pids
)
321 (format *output
* "Do you want to exit lisp anyway [n]? ")
322 (force-output *output
*)
323 (let ((input (string-trim-whitespace (read-line *input
*))))
324 (if (and (plusp (length input
))
325 (or (char= #\y
(char input
0))
326 (char= #\Y
(char input
0))))
327 ;; loop in case more threads get created while trying to exit
328 (do ((pids other-pids
(other-thread-pids)))
330 (map nil
#'sb-thread
:destroy-thread pids
)
332 (return-from exit-cmd
)))))
333 (sb-ext:quit
:unix-status status
)
336 (defun package-cmd (&optional pkg
)
339 (format *output
* "The ~A package is current.~%"
340 (package-name cl
:*package
*)))
341 ((null (find-package (write-to-string pkg
)))
342 (format *output
* "Unknown package: ~A.~%" pkg
))
344 (setf cl
:*package
* (find-package (write-to-string pkg
)))))
347 (defun string-to-list-skip-spaces (str)
348 "Return a list of strings, delimited by spaces, skipping spaces."
349 (declare (type (or null string
) str
))
351 (loop for i
= 0 then
(1+ j
)
352 as j
= (position #\space str
:start i
)
353 when
(not (char= (char str i
) #\space
))
354 collect
(subseq str i j
) while j
)))
356 (let ((last-files-loaded nil
))
357 (defun ld-cmd (&optional string-files
)
359 (setq last-files-loaded string-files
)
360 (setq string-files last-files-loaded
))
361 (dolist (arg (string-to-list-skip-spaces string-files
))
363 (if (string= arg
"~/" :end1
1 :end2
1)
364 (merge-pathnames (parse-namestring
365 (string-left-trim "~/" arg
))
366 (user-homedir-pathname))
368 (format *output
* "loading ~S~%" file
)
372 (defun cf-cmd (string-files)
374 (dolist (arg (string-to-list-skip-spaces string-files
))
379 "Return if x and y are numbers, and x > y"
380 (and (numberp x
) (numberp y
) (> x y
)))
382 (defun newer-file-p (file1 file2
)
383 "Is file1 newer (written later than) file2?"
384 (>-num
(if (probe-file file1
) (file-write-date file1
))
385 (if (probe-file file2
) (file-write-date file2
))))
387 (defun compile-file-as-needed (src-path)
388 "Compiles a file if needed, returns path."
389 (let ((dest-path (compile-file-pathname src-path
)))
390 (when (or (not (probe-file dest-path
))
391 (newer-file-p src-path dest-path
))
392 (ensure-directories-exist dest-path
)
393 (compile-file src-path
:output-file dest-path
))
396 ;;;; implementation of commands
398 (defun apropos-cmd (string)
399 (apropos (string-upcase string
))
400 (fresh-line *output
*)
403 (let ((last-files-loaded nil
))
404 (defun cload-cmd (&optional string-files
)
406 (setq last-files-loaded string-files
)
407 (setq string-files last-files-loaded
))
408 (dolist (arg (string-to-list-skip-spaces string-files
))
409 (format *output
* "loading ~a~%" arg
)
410 (load (compile-file-as-needed arg
)))
413 (defun inspect-cmd (arg)
414 (inspector-fun (eval arg
) nil
*output
*)
417 (defun istep-cmd (&optional arg-string
)
418 (istep (string-to-list-skip-spaces arg-string
) *output
*)
421 (defun describe-cmd (&rest args
)
423 (eval `(describe ,arg
)))
426 (defun macroexpand-cmd (arg)
427 (pprint (macroexpand arg
) *output
*)
430 (defun history-cmd ()
431 (let ((n (length *history
*)))
435 (let ((hist (nth (- n i
1) *history
*)))
436 (format *output
* "~3A " (user-cmd-hnum hist
))
437 (if (stringp (user-cmd-input hist
))
438 (format *output
* "~A~%" (user-cmd-input hist
))
439 (format *output
* "~W~%" (user-cmd-input hist
))))))
442 (defun help-cmd (&optional cmd
)
445 (let ((cmd-entry (find-cmd cmd
)))
447 (format *output
* "Documentation for ~A: ~A~%"
448 (cmd-table-entry-name cmd-entry
)
449 (cmd-table-entry-desc cmd-entry
)))))
451 (format *output
* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
452 (format *output
* "~11A ~4A ~A~%" "<n>" ""
453 "re-execute <n>th history command")
454 (dolist (doc-entry (get-cmd-doc-list :cmd
))
455 (format *output
* "~11A ~4A ~A~%" (first doc-entry
)
456 (second doc-entry
) (third doc-entry
)))))
460 (let ((doc-entries (get-cmd-doc-list :alias
)))
461 (typecase doc-entries
463 (format *output
* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
464 (dolist (doc-entry doc-entries
)
465 (format *output
* "~11A ~4A ~A~%" (first doc-entry
) (second doc-entry
) (third doc-entry
))))
467 (format *output
* "No aliases are defined~%"))))
470 (defun shell-cmd (string-arg)
471 (sb-ext:run-program
"/bin/sh" (list "-c" string-arg
)
472 :input nil
:output
*output
*)
475 (defun pushd-cmd (string-arg)
476 (push string-arg
*dir-stack
*)
482 (let ((dir (pop *dir-stack
*)))
484 (format *output
* "No directory on stack to pop.~%"))
487 (defun pop-cmd (&optional
(n 1))
490 (throw 'repl-catcher
(values :inspect n
)))
491 ((plusp *break-level
*)
492 (throw 'repl-catcher
(values :pop n
))))
495 (defun bt-cmd (&optional
(n most-positive-fixnum
))
496 (sb-debug::backtrace n
))
498 (defun current-cmd ()
499 (sb-debug::describe-debug-command
))
502 (sb-debug::frame-debug-command
0))
505 (sb-debug::bottom-debug-command
))
507 (defun up-cmd (&optional
(n 1))
509 (if (and sb-debug
::*current-frame
*
510 (sb-di:frame-up sb-debug
::*current-frame
*))
511 (sb-debug::up-debug-command
)
513 (format *output
* "Top of the stack")
514 (return-from up-cmd
)))))
516 (defun dn-cmd (&optional
(n 1))
518 (if (and sb-debug
::*current-frame
*
519 (sb-di:frame-down sb-debug
::*current-frame
*))
520 (sb-debug::down-debug-command
)
522 (format *output
* "Bottom of the stack")
523 (return-from dn-cmd
)))))
525 (defun continue-cmd (&optional
(num 0))
526 ;; don't look at first restart
527 (let ((restarts (compute-restarts)))
532 (if (< -
1 num
(length restarts
))
535 (format *output
* "There is no such restart")
536 (return-from continue-cmd
))))
538 (find num
(the list restarts
)
540 :test
(lambda (sym1 sym2
)
541 (string= (symbol-name sym1
)
542 (symbol-name sym2
)))))
544 (format *output
* "~S is invalid as a restart name" num
)
545 (return-from continue-cmd nil
)))))
547 (invoke-restart-interactively restart
)))
548 (format *output
* "~&There are no restarts"))))
551 (when (plusp *break-level
*)
553 (sb-debug::show-restarts
(compute-restarts) *output
*)
554 (let ((sb-debug::*debug-restarts
* (compute-restarts)))
555 (sb-debug::error-debug-command
)))))
558 (sb-debug::print-frame-call sb-debug
::*current-frame
*))
563 (defun local-cmd (&optional var
)
564 (declare (ignore var
))
565 (sb-debug::list-locals-debug-command
))
567 (defun processes-cmd ()
569 (let ((pids (thread-pids))
570 (current-pid (sb-thread:current-thread-id
)))
572 (format *output
* "~&~D" pid
)
573 (when (= pid current-pid
)
574 (format *output
* " [current listener]"))))
576 (format *output
* "~&Threads are not supported in this version of sbcl")
579 (defun kill-cmd (&rest selected-pids
)
581 (let ((pids (thread-pids)))
582 (dolist (selected-pid selected-pids
)
583 (if (find selected-pid pids
:test
#'eql
)
585 (sb-thread:destroy-thread selected-pid
)
586 (format *output
* "~&Thread ~A destroyed" selected-pid
))
587 (format *output
* "~&No thread ~A exists" selected-pid
))))
589 (declare (ignore selected-pids
))
591 (format *output
* "~&Threads are not supported in this version of sbcl")
594 (defun signal-cmd (signal &rest selected-pids
)
596 (let ((pids (thread-pids)))
597 (dolist (selected-pid selected-pids
)
598 (if (find selected-pid pids
:test
#'eql
)
600 (sb-unix:unix-kill selected-pid signal
)
601 (format *output
* "~&Signal ~A sent to thread ~A"
602 signal selected-pid
))
603 (format *output
* "~&No thread ~A exists" selected-pid
))))
605 (declare (ignore signal selected-pids
))
607 (format *output
* "~&Threads are not supported in this version of sbcl")
610 (defun focus-cmd (&optional process
)
612 (declare (ignore process
))
615 (format *output
* "~&Focusing on next thread waiting waiting for the debugger~%"))
618 (sb-thread:release-foreground
)
621 (format *output
* "~&Threads are not supported in this version of sbcl")
625 (invoke-restart-interactively (find-restart 'sb-impl
::toplevel
)))
628 (dolist (dir *dir-stack
*)
629 (format *output
* "~a~%" dir
))
633 ;;;; dispatch table for commands
636 '(("aliases" 3 alias-cmd
"show aliases")
637 ("apropos" 2 apropos-cmd
"show apropos" :parsing
:string
)
638 ("bottom" 3 bottom-cmd
"move to bottom stack frame")
639 ("top" 3 top-cmd
"move to top stack frame")
640 ("bt" 2 bt-cmd
"backtrace `n' stack frames, default all")
641 ("up" 2 up-cmd
"move up `n' stack frames, default 1")
642 ("dn" 2 dn-cmd
"move down `n' stack frames, default 1")
643 ("cd" 2 cd-cmd
"change default diretory" :parsing
:string
)
644 ("ld" 2 ld-cmd
"load a file" :parsing
:string
)
645 ("cf" 2 cf-cmd
"compile file" :parsing
:string
)
646 ("cload" 2 cload-cmd
"compile if needed and load file"
648 ("current" 3 current-cmd
"print the expression for the current stack frame")
649 ("continue" 4 continue-cmd
"continue from a continuable error")
650 ("describe" 2 describe-cmd
"describe an object")
651 ("macroexpand" 2 macroexpand-cmd
"macroexpand an expression")
652 ("package" 2 package-cmd
"change current package")
653 ("error" 3 error-cmd
"print the last error message")
654 ("exit" 2 exit-cmd
"exit sbcl")
655 ("frame" 2 frame-cmd
"print info about the current frame")
656 ("help" 2 help-cmd
"print this help")
657 ("history" 3 history-cmd
"print the recent history")
658 ("inspect" 2 inspect-cmd
"inspect an object")
659 ("istep" 1 istep-cmd
"navigate within inspection of a lisp object" :parsing
:string
)
660 #+sb-thread
("kill" 2 kill-cmd
"kill (destroy) processes")
661 #+sb-thread
("signal" 2 signal-cmd
"send a signal to processes")
662 #+sb-thread
("focus" 2 focus-cmd
"focus the top level on a process")
663 ("local" 3 local-cmd
"print the value of a local variable")
664 ("pwd" 3 pwd-cmd
"print current directory")
665 ("pushd" 2 pushd-cmd
"push directory on stack" :parsing
:string
)
666 ("pop" 3 pop-cmd
"pop up `n' (default 1) break levels")
667 ("popd" 4 popd-cmd
"pop directory from stack")
668 #+sb-thread
("processes" 3 processes-cmd
"list all processes")
669 ("reset" 3 reset-cmd
"reset to top break level")
670 ("trace" 2 trace-cmd
"trace a function")
671 ("untrace" 4 untrace-cmd
"untrace a function")
672 ("dirs" 2 dirs-cmd
"show directory stack")
673 ("shell" 2 shell-cmd
"execute a shell cmd" :parsing
:string
)
674 ("zoom" 2 zoom-cmd
"print the runtime stack")
676 (dolist (cmd cmd-table
)
677 (destructuring-bind (cmd-string abbr-len func-name desc
&key parsing
) cmd
678 (add-cmd-table-entry cmd-string abbr-len func-name desc parsing
))))
680 ;;;; machinery for aliases
682 (defsetf alias
(name &key abbr-len description
) (user-func)
685 (make-cte (quote ,name
) ,user-func
,description nil
:alias
,abbr-len
))
688 (defmacro alias
(name-param args
&rest body
)
692 (name (if (atom name-param
)
695 (when (consp name-param
)
696 (dolist (param (cdr name-param
))
699 (eq param
:case-sensitive
)
701 (setq parsing param
))
705 (setq abbr-index param
)))))
708 (make-cte (quote ,name
) (lambda ,args
,@body
) ,desc
,parsing
:alias
(when ,abbr-index
714 (defun remove-alias (&rest aliases
)
715 (declare (list aliases
))
717 (remove-all (not (null (find :all aliases
)))))
718 (unless remove-all
;; ensure all alias are strings
720 (loop for alias in aliases
726 (symbol-name alias
))))))
729 (when (eq (cmd-table-entry-group cmd
) :alias
)
734 (let ((klen (length key
)))
735 (and (>= (length alias
) klen
)
736 (string-equal (subseq alias
0 klen
)
737 (subseq key
0 klen
)))))
742 (remhash key
*cmd-table-hash
*))
745 ;;;; low-level reading/parsing functions
747 ;;; Skip white space (but not #\NEWLINE), and peek at the next
749 (defun peek-char-non-whitespace (&optional stream
)
750 (do ((char (peek-char nil stream nil
*eof-marker
*)
751 (peek-char nil stream nil
*eof-marker
*)))
752 ((not (whitespace-char-not-newline-p char
)) char
)
755 (defun string-trim-whitespace (str)
756 (string-trim '(#\space
#\tab
#\return
)
759 (defun whitespace-char-p (x)
761 (or (char= x
#\space
)
765 (char= x
#\return
))))
767 (defun whitespace-char-not-newline-p (x)
768 (and (whitespace-char-p x
)
769 (not (char= x
#\newline
))))
771 ;;;; linking into SBCL hooks
773 (defun repl-prompt-fun (stream)
774 (let ((break-level (when (plusp *break-level
*)
776 (frame-number (when (and (plusp *break-level
*)
777 sb-debug
::*current-frame
*)
778 (sb-di::frame-number sb-debug
::*current-frame
*))))
779 (sb-thread::get-foreground
)
781 (if (functionp *prompt
*)
782 (write-string (funcall *prompt
*
787 (prompt-package-name) *cmd-number
*)
795 (prompt-package-name) *cmd-number
*)
797 (format stream
"~&Prompt error> "))
799 (format stream
"~A" prompt
))))))
801 (defun process-cmd (user-cmd)
802 ;; Processes a user command. Returns t if the user-cmd was a top-level
804 (cond ((eq user-cmd
*eof-cmd
*)
807 (format *output
* "EOF~%")
809 ((eq user-cmd
*null-cmd
*)
811 ((eq (user-cmd-func user-cmd
) :cmd-error
)
812 (format *output
* "Unknown top-level command: ~s.~%"
813 (user-cmd-input user-cmd
))
814 (format *output
* "Type `:help' for the list of commands.~%")
816 ((eq (user-cmd-func user-cmd
) :history-error
)
817 (format *output
* "Input numbered ~d is not on the history list~%"
818 (user-cmd-input user-cmd
))
820 ((functionp (user-cmd-func user-cmd
))
821 (add-to-history user-cmd
)
822 (apply (user-cmd-func user-cmd
) (user-cmd-args user-cmd
))
826 (add-to-history user-cmd
)
827 nil
))) ; nope, not in my job description
829 (defun repl-read-form-fun (input output
)
830 ;; Pick off all the leading ACL magic commands, then return a normal
832 (let ((*input
* input
)
834 (loop for user-cmd
= (read-cmd *input
*) do
835 (if (process-cmd user-cmd
)
837 (funcall sb-int
:*repl-prompt-fun
* *output
*)
838 (force-output *output
*))
839 (return (user-cmd-input user-cmd
))))))
842 (setf sb-int
:*repl-prompt-fun
* #'repl-prompt-fun
843 sb-int
:*repl-read-form-fun
* #'repl-read-form-fun
)
845 (defmacro with-new-repl-state
((&rest vars
) &body forms
)
846 (let ((gvars (mapcar (lambda (var) (gensym (symbol-name var
))) vars
)))
847 `(let (,@(mapcar (lambda (var gvar
) `(,gvar
,var
)) vars gvars
))
849 (let ((*noprint
* noprint
))
850 (let (,@(mapcar (lambda (var gvar
) `(,var
,gvar
)) vars gvars
))
853 ,@(mapcar (lambda (var gvar
) `(setf ,gvar
,var
))
856 (defun make-repl-fun ()
857 (with-new-repl-state (*break-level
* *inspect-break
* *continuable-break
*
858 *dir-stack
* *command-char
* *prompt
*
859 *use-short-package-name
* *max-history
* *exit-on-eof
*
860 *history
* *cmd-number
*)
861 (repl :noprint noprint
:break-level
0)))
863 (when (boundp 'sb-impl
::*repl-fun-generator
*)
864 (setq sb-impl
::*repl-fun-generator
* #'make-repl-fun
))