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* (cons :eof nil))
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 (loop as arg = (read string-stream nil *eof-marker*)
115 until (eq arg *eof-marker*)
117 (let ((next-char (peek-char-non-whitespace input-stream)))
119 ((eql next-char *command-char*)
120 (let* ((line (string-trim-whitespace (read-line input-stream)))
121 (first-space-pos (position #\space line))
122 (cmd-string (subseq line 1 first-space-pos))
125 (string-trim-whitespace (subseq line first-space-pos))
127 (declare (string line))
128 (if (numberp (read-from-string cmd-string))
129 (let ((cmd (get-history (read-from-string cmd-string))))
130 (if (eq cmd *null-cmd*)
131 (make-user-cmd :func :history-error
132 :input (read-from-string cmd-string))
133 (make-user-cmd :func (user-cmd-func cmd)
134 :input (user-cmd-input cmd)
135 :args (user-cmd-args cmd)
136 :hnum *cmd-number*)))
137 (let ((cmd-entry (find-cmd cmd-string)))
139 (make-user-cmd :func (cmd-table-entry-func cmd-entry)
142 (cmd-table-entry-parsing cmd-entry)
145 (make-user-cmd :func :cmd-error
148 ((eql next-char #\newline)
149 (read-char input-stream)
152 (let ((form (read input-stream nil *eof-marker*)))
153 (if (eq form *eof-marker*)
155 (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
157 (defun make-cte (name-param func desc parsing group abbr-len)
158 (let ((name (etypecase name-param
162 (string-downcase (write-to-string name-param))))))
163 (make-cmd-table-entry :name name :func func :desc desc
164 :parsing parsing :group group
165 :abbr-len (if abbr-len
169 (defun %add-entry (cmd &optional abbr-len)
170 (let* ((name (cmd-table-entry-name cmd))
174 (dotimes (i (length name))
175 (when (>= i (1- alen))
176 (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
179 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
181 (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len)
184 (defun find-cmd (cmdstr)
185 (gethash (string-downcase cmdstr) *cmd-table-hash*))
187 (defun user-cmd= (c1 c2)
188 "Returns T if two user commands are equal"
189 (and (eq (user-cmd-func c1) (user-cmd-func c2))
190 (equal (user-cmd-args c1) (user-cmd-args c2))
191 (equal (user-cmd-input c1) (user-cmd-input c2))))
193 (defun add-to-history (cmd)
194 (unless (and *history* (user-cmd= cmd (car *history*)))
195 (when (>= (length *history*) *max-history*)
196 (setq *history* (nbutlast *history* (+ (length *history*) *max-history* 1))))
198 (incf *cmd-number*)))
200 (defun get-history (n)
201 (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
206 (defun get-cmd-doc-list (&optional (group :cmd))
207 "Return list of all commands"
209 (maphash (lambda (k v)
211 (= (length k) (length (cmd-table-entry-name v)))
212 (eq (cmd-table-entry-group v) group))
214 (if (= (cmd-table-entry-abbr-len v)
217 (subseq k 0 (cmd-table-entry-abbr-len v)))
218 (cmd-table-entry-desc v)) cmds)))
220 (sort cmds #'string-lessp :key #'car)))
222 (defun cd-cmd (&optional string-dir)
224 ((or (zerop (length string-dir))
225 (string= string-dir "~"))
226 (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
228 (let ((new (truename string-dir)))
229 (when (pathnamep new)
230 (setf cl:*default-pathname-defaults* new)))))
231 (format *repl-output* "~A~%" (namestring cl:*default-pathname-defaults*))
235 (format *repl-output* "Lisp's current working directory is ~s.~%"
236 (namestring cl:*default-pathname-defaults*))
239 (defun trace-cmd (&rest args)
241 (format *repl-output* "~A~%" (eval (sb-debug::expand-trace args)))
242 (format *repl-output* "~A~%" (sb-debug::%list-traced-funs)))
245 (defun untrace-cmd (&rest args)
247 (format *repl-output* "~A~%"
249 (sb-int:collect ((res))
250 (let ((current args))
252 (unless current (return))
253 (let ((name (pop current)))
254 (res (if (eq name :function)
255 `(sb-debug::untrace-1 ,(pop current))
256 `(sb-debug::untrace-1 ',name))))))
257 `(progn ,@(res) t))))
258 (format *repl-output* "~A~%" (eval (sb-debug::untrace-all))))
262 (defun thread-pids ()
263 "Return a list of the pids for all threads"
264 (let ((offset (* 4 sb-vm::thread-pid-slot)))
265 (sb-thread::mapcar-threads
266 #'(lambda (sap) (sb-sys:sap-ref-32 sap offset)))))
269 (defun other-thread-pids ()
270 "Returns a list of pids for all threads except the current process"
271 (delete (sb-thread:current-thread-id) (thread-pids) :test #'eql))
273 (defun exit-cmd (&optional (status 0))
275 (let ((other-pids (other-thread-pids)))
277 (format *repl-output* "There exists the following processes~%")
278 (format *repl-output* "~{~5d~%~}" other-pids)
279 (format *repl-output* "Do you want to exit lisp anyway [n]? ")
280 (force-output *repl-output*)
281 (let ((input (string-trim-whitespace (read-line *repl-input*))))
282 (if (and (plusp (length input))
283 (or (char= #\y (char input 0))
284 (char= #\Y (char input 0))))
285 ;; loop in case more threads get created while trying to exit
286 (do ((pids other-pids (other-thread-pids)))
288 (map nil #'sb-thread:destroy-thread pids)
290 (return-from exit-cmd)))))
291 (quit :unix-status status)
294 (defun package-cmd (&optional pkg)
297 (format *repl-output* "The ~A package is current.~%"
298 (package-name cl:*package*)))
299 ((null (find-package (write-to-string pkg)))
300 (format *repl-output* "Unknown package: ~A.~%" pkg))
302 (setf cl:*package* (find-package (write-to-string pkg)))))
305 (defun string-to-list-skip-spaces (str)
306 "Return a list of strings, delimited by spaces, skipping spaces."
307 (declare (string str))
309 (loop for i = 0 then (1+ j)
310 as j = (position #\space str :start i)
311 when (not (char= (char str i) #\space))
312 collect (subseq str i j) while j)))
314 (let ((last-files-loaded nil))
315 (defun ld-cmd (&optional string-files)
317 (setq last-files-loaded string-files)
318 (setq string-files last-files-loaded))
319 (dolist (arg (string-to-list-skip-spaces string-files))
320 (format *repl-output* "loading ~a~%" arg)
324 (defun cf-cmd (string-files)
326 (dolist (arg (string-to-list-skip-spaces string-files))
331 "Return if x and y are numbers, and x > y"
332 (and (numberp x) (numberp y) (> x y)))
334 (defun newer-file-p (file1 file2)
335 "Is file1 newer (written later than) file2?"
336 (>-num (if (probe-file file1) (file-write-date file1))
337 (if (probe-file file2) (file-write-date file2))))
339 (defun compile-file-as-needed (src-path)
340 "Compiles a file if needed, returns path."
341 (let ((dest-path (compile-file-pathname src-path)))
342 (when (or (not (probe-file dest-path))
343 (newer-file-p src-path dest-path))
344 (ensure-directories-exist dest-path)
345 (compile-file src-path :output-file dest-path))
348 ;;;; implementation of commands
350 (defun apropos-cmd (string)
351 (apropos (string-upcase string))
354 (let ((last-files-loaded nil))
355 (defun cload-cmd (&optional string-files)
357 (setq last-files-loaded string-files)
358 (setq string-files last-files-loaded))
359 (dolist (arg (string-to-list-skip-spaces string-files))
360 (format *repl-output* "loading ~a~%" arg)
361 (load (compile-file-as-needed arg)))
364 (defun inspect-cmd (arg)
365 (inspector arg nil *repl-output*)
368 (defun istep-cmd (&optional arg-string)
369 (istep arg-string *repl-output*)
372 (defun describe-cmd (&rest args)
374 (eval `(describe ,arg)))
377 (defun macroexpand-cmd (arg)
378 (pprint (macroexpand arg) *repl-output*)
381 (defun history-cmd ()
382 (let ((n (length *history*)))
386 (let ((hist (nth (- n i 1) *history*)))
387 (format *repl-output* "~3A " (user-cmd-hnum hist))
388 (if (stringp (user-cmd-input hist))
389 (format *repl-output* "~A~%" (user-cmd-input hist))
390 (format *repl-output* "~W~%" (user-cmd-input hist))))))
393 (defun help-cmd (&optional cmd)
396 (let ((cmd-entry (find-cmd cmd)))
398 (format *repl-output* "Documentation for ~A: ~A~%"
399 (cmd-table-entry-name cmd-entry)
400 (cmd-table-entry-desc cmd-entry)))))
402 (format *repl-output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
403 (format *repl-output* "~11A ~4A ~A~%" "<n>" ""
404 "re-execute <n>th history command")
405 (dolist (doc-entry (get-cmd-doc-list :cmd))
406 (format *repl-output* "~11A ~4A ~A~%" (first doc-entry)
407 (second doc-entry) (third doc-entry)))))
411 (let ((doc-entries (get-cmd-doc-list :alias)))
412 (typecase doc-entries
414 (format *repl-output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
415 (dolist (doc-entry doc-entries)
416 (format *repl-output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
418 (format *repl-output* "No aliases are defined~%"))))
421 (defun shell-cmd (string-arg)
422 (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
423 :input nil :output *repl-output*)
426 (defun pushd-cmd (string-arg)
427 (push string-arg *dir-stack*)
428 (cd-cmd *repl-output* string-arg)
433 (let ((dir (pop *dir-stack*)))
435 (format *repl-output* "No directory on stack to pop.~%"))
438 (defun pop-cmd (&optional (n 1))
439 (let ((new-level (- (length *break-stack*) n 1)))
440 (when (minusp new-level)
442 (dotimes (i (- (length *break-stack*) new-level 1))
443 (pop *break-stack*)))
445 (do* ((i (1- (length *break-stack*)) (1- i))
447 ((or found (minusp i)))
448 (let ((inspect (break-data-inspect (nth i *break-stack*))))
450 (set-current-inspect inspect)
454 (defun continue-cmd (n)
455 (let ((restarts (break-data-restarts (car *break-stack*))))
457 (if (< -1 n (length restarts))
459 (invoke-restart-interactively (nth n restarts))
461 (format *repl-output* "~&There is no such restart"))
462 (format *repl-output* "~&There are no restarts"))))
467 (defun current-cmd ()
476 (defun local-cmd (&optional var)
479 (defun processes-cmd ()
481 (let ((pids (thread-pids))
482 (current-pid (sb-thread:current-thread-id)))
484 (format *repl-output* "~&~D" pid)
485 (when (= pid current-pid)
486 (format *repl-output* " [current listener]"))))
488 (format *repl-output* "~&Threads are not supported in this version of sbcl")
491 (defun kill-cmd (selected-pid)
493 (let ((pids (thread-pids)))
494 (if (find selected-pid pids :test #'eql)
496 (sb-thread:destroy-thread selected-pid)
497 (format *repl-output* "Thread ~D destroyed" selected-pid))
498 (format *repl-output* "No thread ~D exists" selected-pid)))
500 (declare (ignore selected-pid))
502 (format *repl-output* "~&Threads are not supported in this version of sbcl")
506 (setf *break-stack* (last *break-stack*))
510 (dolist (dir *dir-stack*)
511 (format *repl-output* "~a~%" dir))
515 ;;;; dispatch table for commands
518 '(("aliases" 3 alias-cmd "show aliases")
519 ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
520 ("cd" 2 cd-cmd "change default diretory" :parsing :string)
521 ("ld" 2 ld-cmd "load a file" :parsing :string)
522 ("cf" 2 cf-cmd "compile file" :parsing :string)
523 ("cload" 2 cload-cmd "compile if needed and load file"
525 #+aclrepl-debugger("current" 3 current-cmd "print the expression for the current stack frame")
526 #+aclrepl-debugger ("continue" 4 continue-cmd "continue from a continuable error")
527 ("describe" 2 describe-cmd "describe an object")
528 ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
529 ("package" 2 package-cmd "change current package")
530 #+aclrepl-debugger ("error" 3 error-cmd "print the last error message")
531 ("exit" 2 exit-cmd "exit sbcl")
532 #+aclrepl-debugger("frame" 2 frame-cmd "print info about the current frame")
533 ("help" 2 help-cmd "print this help")
534 ("history" 3 history-cmd "print the recent history")
535 ("inspect" 2 inspect-cmd "inspect an object")
536 ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
537 #+sb-thread ("kill" 2 kill-cmd "kill a process")
538 #+aclrepl-debugger("local" 3 local-cmd "print the value of a local variable")
539 ("pwd" 3 pwd-cmd "print current directory")
540 ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
541 ("pop" 3 pop-cmd "pop up `n' (default 1) break levels")
542 ("popd" 4 popd-cmd "pop directory from stack")
543 #+sb-thread ("processes" 3 processes-cmd "list all processes")
544 ("trace" 2 trace-cmd "trace a function")
545 ("untrace" 4 untrace-cmd "untrace a function")
546 ("dirs" 2 dirs-cmd "show directory stack")
547 ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string)
548 #+aclrepl-debugger ("zoom" 2 zoom-cmd "print the runtime stack")
550 (dolist (cmd cmd-table)
551 (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
552 (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
554 ;;;; machinery for aliases
556 (defsetf alias (name &key abbr-len description) (user-func)
559 (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len))
562 (defmacro alias (name-param args &rest body)
566 (name (if (atom name-param)
569 (when (consp name-param)
570 (dolist (param (cdr name-param))
573 (eq param :case-sensitive)
575 (setq parsing param))
579 (setq abbr-index param)))))
582 (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index
588 (defun remove-alias (&rest aliases)
589 (declare (list aliases))
591 (remove-all (not (null (find :all aliases)))))
592 (unless remove-all ;; ensure all alias are strings
594 (loop for alias in aliases
600 (symbol-name alias))))))
603 (when (eq (cmd-table-entry-group cmd) :alias)
608 (let ((klen (length key)))
609 (and (>= (length alias) klen)
610 (string-equal (subseq alias 0 klen)
611 (subseq key 0 klen)))))
616 (remhash key *cmd-table-hash*))
619 ;;;; low-level reading/parsing functions
621 ;;; Skip white space (but not #\NEWLINE), and peek at the next
623 (defun peek-char-non-whitespace (&optional stream)
624 (do ((char (peek-char nil stream nil *eof-marker*)
625 (peek-char nil stream nil *eof-marker*)))
626 ((not (whitespace-char-not-newline-p char)) char)
629 (defun string-trim-whitespace (str)
630 (string-trim '(#\space #\tab #\return)
633 (defun whitespace-char-not-newline-p (x)
635 (or (char= x #\space)
637 (char= x #\return))))
640 ;;;; linking into SBCL hooks
642 (defun repl-prompt-fun (stream)
643 (let* ((break-data (car *break-stack*))
644 (break-level (break-data-level break-data)))
645 (when (zerop break-level)
646 (setq break-level nil))
647 (if (functionp *prompt*)
648 (write-string (funcall *prompt* break-level
649 (break-data-inspect-initiated break-data)
650 (break-data-continuable break-data)
651 (prompt-package-name) *cmd-number*)
654 (format nil *prompt* break-level
655 (break-data-inspect-initiated break-data)
656 (break-data-continuable break-data)
657 (prompt-package-name) *cmd-number*)
659 (format stream "~&Prompt error> "))
661 (format stream "~&~A" prompt))))))
663 (defun process-cmd (user-cmd input-stream output-stream)
664 ;; Processes a user command. Returns t if the user-cmd was a top-level
666 (cond ((eq user-cmd *eof-cmd*)
669 (format output-stream "EOF~%")
671 ((eq user-cmd *null-cmd*)
673 ((eq (user-cmd-func user-cmd) :cmd-error)
674 (format output-stream "Unknown top-level command: ~s.~%"
675 (user-cmd-input user-cmd))
676 (format output-stream "Type `:help' for the list of commands.~%")
678 ((eq (user-cmd-func user-cmd) :history-error)
679 (format output-stream "Input numbered ~d is not on the history list~%"
680 (user-cmd-input user-cmd))
682 ((functionp (user-cmd-func user-cmd))
683 (add-to-history user-cmd)
684 (let ((*repl-output* output-stream)
685 (*repl-input* input-stream))
686 (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd)))
690 (add-to-history user-cmd)
691 nil))) ; nope, not in my job description
693 (defun repl-read-form-fun (input-stream output-stream)
694 ;; Pick off all the leading ACL magic commands, then return a normal
696 (loop for user-cmd = (read-cmd input-stream) do
697 (if (process-cmd user-cmd input-stream output-stream)
699 (funcall sb-int:*repl-prompt-fun* output-stream)
700 (force-output output-stream))
701 (return (user-cmd-input user-cmd)))))
704 (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
705 sb-int:*repl-read-form-fun* #'repl-read-form-fun)
707 ;;; Break level processing
709 ;; use an initial break-level to hold current inspect toplevel at
712 (defun new-break (&key restarts inspect continuable)
714 (make-break-data :level (length *break-stack*)
717 :inspect-initiated (when inspect t)
718 :continuable continuable)
721 (defun set-break-inspect (inspect)
722 "sets the inspect data for the current break level"
723 (setf (break-data-inspect (car *break-stack*)) inspect))
725 ) ;; close special variables bindings