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)
18 (eval-when (:compile-toplevel :load-toplevel :execute)
19 (defparameter *default-prompt* "~&~A(~d): "
20 "The default prompt."))
21 (defparameter *prompt* #.*default-prompt*
22 "The current prompt string or formatter function.")
23 (defparameter *use-short-package-name* t
24 "when T, use the shortnest package nickname in a prompt")
25 (defparameter *dir-stack* nil
26 "The top-level directory stack")
27 (defparameter *command-char* #\:
28 "Prefix character for a top-level command")
29 (defvar *max-history* 24
30 "Maximum number of history commands to remember")
31 (defvar *exit-on-eof* t
32 "If T, then exit when the EOF character is entered.")
33 (defparameter *history* nil
35 (defparameter *cmd-number* 1
36 "Number of the next command")
38 (declaim (type list *history*))
41 (input nil) ; input, maybe a string or form
42 (func nil) ; cmd func entered, overloaded
43 ; (:eof :null-cmd :cmd-error :history-error)
44 (args nil) ; args for cmd func
45 (hnum nil)) ; history number
47 (defvar *eof-marker* (cons :eof nil))
48 (defvar *eof-cmd* (make-user-cmd :func :eof))
49 (defvar *null-cmd* (make-user-cmd :func :null-cmd))
51 (defparameter *cmd-table-hash*
52 (make-hash-table :size 30 :test #'equal))
54 ;; Set up binding for multithreading
56 (let ((*prompt* #.*default-prompt*)
57 (*use-short-package-name* t)
65 (defun prompt-package-name ()
66 (if *use-short-package-name*
68 (package-nicknames cl:*package*)
69 (list (package-name cl:*package*)))
70 (lambda (a b) (< (length a) (length b)))))
71 (package-name cl:*package*)))
73 (defun read-cmd (input-stream)
74 ;; Reads a command from the user and returns a user-cmd object
75 (flet ((parse-args (parsing args-string)
78 (if (zerop (length args-string))
82 (let ((string-stream (make-string-input-stream args-string)))
83 (loop as arg = (read string-stream nil *eof-marker*)
84 until (eq arg *eof-marker*)
86 (let ((next-char (peek-char-non-whitespace input-stream)))
88 ((eql next-char *command-char*)
89 (let* ((line (string-trim-whitespace (read-line input-stream)))
90 (first-space-pos (position #\space line))
91 (cmd-string (subseq line 1 first-space-pos))
94 (string-trim-whitespace (subseq line first-space-pos))
96 (declare (string line))
97 (if (numberp (read-from-string cmd-string))
98 (let ((cmd (get-history (read-from-string cmd-string))))
99 (if (eq cmd *null-cmd*)
100 (make-user-cmd :func :history-error
101 :input (read-from-string cmd-string))
102 (make-user-cmd :func (user-cmd-func cmd)
103 :input (user-cmd-input cmd)
104 :args (user-cmd-args cmd)
105 :hnum *cmd-number*)))
106 (let ((cmd-entry (find-cmd cmd-string)))
108 (make-user-cmd :func (cmd-table-entry-func cmd-entry)
111 (cmd-table-entry-parsing cmd-entry)
114 (make-user-cmd :func :cmd-error
117 ((eql next-char #\newline)
118 (read-char input-stream)
121 (let ((form (read input-stream nil *eof-marker*)))
122 (if (eq form *eof-marker*)
124 (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
127 (defstruct cmd-table-entry
128 (name nil) ; name of command
129 (func nil) ; function handler
130 (desc nil) ; short description
131 (parsing nil) ; (:string :case-sensitive nil)
132 (group nil)) ; command group (:cmd or :alias)
134 (defun make-cte (name-param func desc parsing group)
135 (let ((name (etypecase name-param
139 (string-downcase (write-to-string name-param))))))
140 (make-cmd-table-entry :name name :func func :desc desc
141 :parsing parsing :group group)))
143 (defun %add-entry (cmd &optional abbr-len)
144 (let* ((name (cmd-table-entry-name cmd))
148 (dotimes (i (length name))
149 (when (>= i (1- alen))
150 (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
153 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
155 (make-cte cmd-string (symbol-function func-name) desc parsing :cmd)
158 (defun find-cmd (cmdstr)
159 (gethash (string-downcase cmdstr) *cmd-table-hash*))
161 (defun user-cmd= (c1 c2)
162 "Returns T if two user commands are equal"
163 (and (eq (user-cmd-func c1) (user-cmd-func c2))
164 (equal (user-cmd-args c1) (user-cmd-args c2))
165 (equal (user-cmd-input c1) (user-cmd-input c2))))
167 (defun add-to-history (cmd)
168 (unless (and *history* (user-cmd= cmd (car *history*)))
169 (when (>= (length *history*) *max-history*)
170 (setq *history* (nbutlast *history* (+ (length *history*) *max-history* 1))))
172 (incf *cmd-number*)))
174 (defun get-history (n)
175 (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
180 (defun get-cmd-doc-list (&optional (group :cmd))
181 "Return list of all commands"
183 (maphash (lambda (k v)
185 (eql (length k) (length (cmd-table-entry-name v)))
186 (eq (cmd-table-entry-group v) group))
187 (push (list k (cmd-table-entry-desc v)) cmds)))
189 (sort cmds #'string-lessp :key #'car)))
191 (defun cd-cmd (output-stream &optional string-dir)
193 ((or (zerop (length string-dir))
194 (string= string-dir "~"))
195 (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
197 (let ((new (truename string-dir)))
198 (when (pathnamep new)
199 (setf cl:*default-pathname-defaults* new)))))
200 (format output-stream "~A~%" (namestring cl:*default-pathname-defaults*))
203 (defun pwd-cmd (output-stream)
204 (format output-stream "Lisp's current working directory is ~s.~%"
205 (namestring cl:*default-pathname-defaults*))
208 (defun trace-cmd (output-stream &rest args)
210 (format output-stream "~A~%" (eval (sb-debug::expand-trace args)))
211 (format output-stream "~A~%" (sb-debug::%list-traced-funs)))
214 (defun untrace-cmd (output-stream &rest args)
216 (format output-stream "~A~%"
218 (sb-int:collect ((res))
219 (let ((current args))
221 (unless current (return))
222 (let ((name (pop current)))
223 (res (if (eq name :function)
224 `(sb-debug::untrace-1 ,(pop current))
225 `(sb-debug::untrace-1 ',name))))))
226 `(progn ,@(res) t))))
227 (format output-stream "~A~%" (eval (sb-debug::untrace-all))))
230 (defun exit-cmd (output-stream &optional (status 0))
231 (declare (ignore output-stream))
232 (quit :unix-status status)
235 (defun package-cmd (output-stream &optional pkg)
238 (format output-stream "The ~A package is current.~%"
239 (package-name cl:*package*)))
240 ((null (find-package (write-to-string pkg)))
241 (format output-stream "Unknown package: ~A.~%" pkg))
243 (setf cl:*package* (find-package (write-to-string pkg)))))
246 (defun string-to-list-skip-spaces (str)
247 "Return a list of strings, delimited by spaces, skipping spaces."
249 (loop for i = 0 then (1+ j)
250 as j = (position #\space str :start i)
251 when (not (char= (char str i) #\space))
252 collect (subseq str i j) while j)))
254 (let ((last-files-loaded nil))
255 (defun ld-cmd (output-stream &optional string-files)
257 (setq last-files-loaded string-files)
258 (setq string-files last-files-loaded))
259 (dolist (arg (string-to-list-skip-spaces string-files))
260 (format output-stream "loading ~a~%" arg)
264 (defun cf-cmd (output-stream string-files)
265 (declare (ignore output-stream))
267 (dolist (arg (string-to-list-skip-spaces string-files))
272 "Return if x and y are numbers, and x > y"
273 (and (numberp x) (numberp y) (> x y)))
275 (defun newer-file-p (file1 file2)
276 "Is file1 newer (written later than) file2?"
277 (>-num (if (probe-file file1) (file-write-date file1))
278 (if (probe-file file2) (file-write-date file2))))
280 (defun compile-file-as-needed (src-path)
281 "Compiles a file if needed, returns path."
282 (let ((dest-path (compile-file-pathname src-path)))
283 (when (or (not (probe-file dest-path))
284 (newer-file-p src-path dest-path))
285 (ensure-directories-exist dest-path)
286 (compile-file src-path :output-file dest-path))
289 ;;;; implementation of commands
291 (defun apropos-cmd (output-stream string)
292 (declare (ignore output-stream))
293 (apropos (string-upcase string))
296 (let ((last-files-loaded nil))
297 (defun cload-cmd (output-stream &optional string-files)
299 (setq last-files-loaded string-files)
300 (setq string-files last-files-loaded))
301 (dolist (arg (string-to-list-skip-spaces string-files))
302 (format output-stream "loading ~a~%" arg)
303 (load (compile-file-as-needed arg)))
306 (defun inspect-cmd (output-stream arg)
307 (inspector arg nil output-stream)
310 (defun istep-cmd (output-stream &optional arg-string)
311 (istep arg-string output-stream)
314 (defun describe-cmd (output-stream &rest args)
315 (declare (ignore output-stream))
317 (eval `(describe ,arg)))
320 (defun macroexpand-cmd (output-stream arg)
321 (pprint (macroexpand arg) output-stream)
324 (defun history-cmd (output-stream)
325 (let ((n (length *history*)))
329 (let ((hist (nth (- n i 1) *history*)))
330 (format output-stream "~3A ~A~%" (user-cmd-hnum hist)
331 (user-cmd-input hist)))))
334 (defun help-cmd (output-stream &optional cmd)
337 (let ((cmd-entry (find-cmd cmd)))
339 (format output-stream "Documentation for ~A: ~A~%"
340 (cmd-table-entry-name cmd-entry)
341 (cmd-table-entry-desc cmd-entry)))))
343 (format output-stream "~13A ~a~%" "Command" "Description")
344 (format output-stream "------------- -------------~%")
345 (format output-stream "~13A ~A~%" "n"
346 "(for any number n) recall nth command from history list")
347 (dolist (doc-entry (get-cmd-doc-list :cmd))
348 (format output-stream "~13A ~A~%" (car doc-entry) (cadr doc-entry)))))
351 (defun alias-cmd (output-stream)
352 (let ((doc-entries (get-cmd-doc-list :alias)))
353 (typecase doc-entries
355 (format output-stream "~13A ~a~%" "Alias" "Description")
356 (format output-stream "------------- -------------~%")
357 (dolist (doc-entry doc-entries)
358 (format output-stream "~13A ~A~%" (car doc-entry) (cadr doc-entry))))
360 (format output-stream "No aliases are defined~%"))))
363 (defun shell-cmd (output-stream string-arg)
364 (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
365 :input nil :output output-stream)
368 (defun pushd-cmd (output-stream string-arg)
369 (push string-arg *dir-stack*)
370 (cd-cmd output-stream string-arg)
373 (defun popd-cmd (output-stream)
375 (let ((dir (pop *dir-stack*)))
377 (format output-stream "No directory on stack to pop.~%"))
380 (defun dirs-cmd (output-stream)
381 (dolist (dir *dir-stack*)
382 (format output-stream "~a~%" dir))
385 ;;;; dispatch table for commands
388 '(("aliases" 3 alias-cmd "show aliases")
389 ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
390 ("cd" 2 cd-cmd "change default diretory" :parsing :string)
391 ("ld" 2 ld-cmd "load a file" :parsing :string)
392 ("cf" 2 cf-cmd "compile file" :parsing :string)
393 ("cload" 2 cload-cmd "compile if needed and load file"
395 ("describe" 2 describe-cmd "describe an object")
396 ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
397 ("package" 2 package-cmd "change current package")
398 ("exit" 2 exit-cmd "exit sbcl")
399 ("help" 2 help-cmd "print this help")
400 ("history" 3 history-cmd "print the recent history")
401 ("inspect" 2 inspect-cmd "inspect an object")
402 ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
403 ("pwd" 3 pwd-cmd "print current directory")
404 ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
405 ("popd" 2 popd-cmd "pop directory from stack")
406 ("trace" 2 trace-cmd "trace a function")
407 ("untrace" 4 untrace-cmd "untrace a function")
408 ("dirs" 2 dirs-cmd "show directory stack")
409 ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string))))
410 (dolist (cmd cmd-table)
411 (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
412 (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
414 ;;;; machinery for aliases
416 (defsetf alias (name) (user-func)
419 (make-cte (quote ,name) ,user-func "" nil :alias))
422 (defmacro alias (name-param args &rest body)
426 (name (if (atom name-param)
429 (when (consp name-param)
430 (dolist (param (cdr name-param))
433 (eq param :case-sensitive)
435 (setq parsing param))
439 (setq abbr-index param)))))
442 (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias)
447 (defun remove-alias (&rest aliases)
448 (declare (list aliases))
450 (remove-all (not (null (find :all aliases)))))
451 (unless remove-all ;; ensure all alias are strings
453 (loop for alias in aliases
459 (symbol-name alias))))))
462 (when (eq (cmd-table-entry-group cmd) :alias)
467 (let ((klen (length key)))
468 (and (>= (length alias) klen)
469 (string-equal (subseq alias 0 klen)
470 (subseq key 0 klen)))))
475 (remhash key *cmd-table-hash*))
478 ;;;; low-level reading/parsing functions
480 ;;; Skip white space (but not #\NEWLINE), and peek at the next
482 (defun peek-char-non-whitespace (&optional stream)
483 (do ((char (peek-char nil stream nil *eof-marker*)
484 (peek-char nil stream nil *eof-marker*)))
485 ((not (whitespace-char-not-newline-p char)) char)
488 (defun string-trim-whitespace (str)
489 (string-trim '(#\space #\tab #\return)
492 (defun whitespace-char-not-newline-p (x)
494 (or (char= x #\space)
496 (char= x #\return))))
499 ;;;; linking into SBCL hooks
501 (defun repl-prompt-fun (stream)
502 (if (functionp *prompt*)
503 (write-string (funcall *prompt* (prompt-package-name) *cmd-number*)
505 (format stream *prompt* (prompt-package-name) *cmd-number*)))
507 (defun process-cmd (user-cmd output-stream)
508 ;; Processes a user command. Returns t if the user-cmd was a top-level
510 (cond ((eq user-cmd *eof-cmd*)
513 (format output-stream "EOF~%")
515 ((eq user-cmd *null-cmd*)
517 ((eq (user-cmd-func user-cmd) :cmd-error)
518 (format output-stream "Unknown top-level command: ~s.~%"
519 (user-cmd-input user-cmd))
520 (format output-stream "Type `:help' for the list of commands.~%")
522 ((eq (user-cmd-func user-cmd) :history-error)
523 (format output-stream "Input numbered ~d is not on the history list~%"
524 (user-cmd-input user-cmd))
526 ((functionp (user-cmd-func user-cmd))
527 (add-to-history user-cmd)
528 (apply (user-cmd-func user-cmd) output-stream (user-cmd-args user-cmd))
532 (add-to-history user-cmd)
533 nil))) ; nope, not in my job description
535 (defun repl-read-form-fun (input-stream output-stream)
536 ;; Pick off all the leading ACL magic commands, then return a normal
538 (loop for user-cmd = (read-cmd input-stream) do
539 (if (process-cmd user-cmd output-stream)
541 (repl-prompt-fun output-stream)
542 (force-output output-stream))
543 (return (user-cmd-input user-cmd)))))
546 (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
547 sb-int:*repl-read-form-fun* #'repl-read-form-fun)
549 ) ;; close special variables bindings