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 ;; FIXME: should we be exporting anything else?
13 (:export #:*prompt* #:*exit-on-eof* #:*max-history*
14 #:*use-short-package-name* #:*command-char*
17 (cl:in-package :sb-aclrepl)
19 (eval-when (:compile-toplevel :load-toplevel :execute)
20 (defparameter *default-prompt* "~A(~d): "
21 "The default prompt."))
22 (defparameter *prompt* #.*default-prompt*
23 "The current prompt string or formatter function.")
24 (defparameter *use-short-package-name* t
25 "when T, use the shortnest package nickname in a prompt")
26 (defparameter *dir-stack* nil
27 "The top-level directory stack")
28 (defparameter *command-char* #\:
29 "Prefix character for a top-level command")
30 (defvar *max-history* 24
31 "Maximum number of history commands to remember")
32 (defvar *exit-on-eof* t
33 "If T, then exit when the EOF character is entered.")
34 (defparameter *history* nil
36 (defparameter *cmd-number* 0
37 "Number of the current command")
40 (input nil) ; input, maybe a string or form
41 (func nil) ; cmd func entered, overloaded (:eof :null-cmd))
42 (args nil) ; args for cmd func
43 (hnum nil)) ; history number
45 (defvar *eof-marker* (cons :eof nil))
46 (defvar *eof-cmd* (make-user-cmd :func :eof))
47 (defvar *null-cmd* (make-user-cmd :func :null-cmd))
49 (defun prompt-package-name ()
50 (if *use-short-package-name*
52 (package-nicknames cl:*package*)
53 (list (package-name cl:*package*)))
55 (package-name cl:*package*)))
57 (defun read-cmd (input-stream)
58 (flet ((parse-args (parsing args-string)
61 (if (zerop (length args-string))
65 (let ((string-stream (make-string-input-stream args-string)))
66 (loop as arg = (read string-stream nil *eof-marker*)
67 until (eq arg *eof-marker*)
69 (let ((next-char (peek-char-non-whitespace input-stream)))
71 ((eql next-char *command-char*)
72 (let* ((line (string-trim-whitespace (read-line input-stream)))
73 (first-space-pos (position #\space line))
74 (cmd-string (subseq line 1 first-space-pos))
77 (string-trim-whitespace (subseq line first-space-pos))
79 (if (numberp (read-from-string cmd-string))
80 (get-history (read-from-string cmd-string))
81 (let ((cmd-entry (find-cmd cmd-string)))
83 (make-user-cmd :func (cmd-table-entry-func cmd-entry)
86 (cmd-table-entry-parsing cmd-entry)
90 (format t "Unknown top-level command: ~s.~%" cmd-string)
91 (format t "Type `:help' for the list of commands.~%")
94 ((eql next-char #\newline)
95 (read-char input-stream)
98 (let ((form (read input-stream nil *eof-marker*)))
99 (if (eq form *eof-marker*)
101 (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
103 (defparameter *cmd-table-hash*
104 (make-hash-table :size 30 :test #'equal))
107 (defstruct cmd-table-entry
108 (name nil) ; name of command
109 (func nil) ; function handler
110 (desc nil) ; short description
111 (parsing nil) ; (:string :case-sensitive nil)
112 (group nil)) ; command group (:cmd or :alias)
114 (defun make-cte (name-param func desc parsing group)
115 (let ((name (etypecase name-param
119 (string-downcase (write-to-string name-param))))))
120 (make-cmd-table-entry :name name :func func :desc desc
121 :parsing parsing :group group)))
123 (defun %add-entry (cmd &optional abbr-len)
124 (let* ((name (cmd-table-entry-name cmd))
128 (dotimes (i (length name))
129 (when (>= i (1- alen))
130 (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
133 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
135 (make-cte cmd-string (symbol-function func-name) desc parsing :cmd)
138 (defun find-cmd (cmdstr)
139 (gethash (string-downcase cmdstr) *cmd-table-hash*))
141 (defun user-cmd= (c1 c2)
142 "Returns T if two user commands are equal"
143 (if (or (not (user-cmd-p c1)) (not (user-cmd-p c2)))
145 (format t "Error: ~s or ~s is not a user-cmd" c1 c2)
147 (and (eq (user-cmd-func c1) (user-cmd-func c2))
148 (equal (user-cmd-args c1) (user-cmd-args c2))
149 (equal (user-cmd-input c1) (user-cmd-input c2)))))
151 (defun add-to-history (cmd)
152 (unless (and *history* (user-cmd= cmd (car *history*)))
153 (when (>= (length *history*) *max-history*)
154 (setq *history* (nbutlast *history* (+ (length *history*) *max-history* 1))))
155 (push cmd *history*)))
157 (defun get-history (n)
158 (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
162 (format t "Input numbered %d is not on the history list.." n)
165 (defun get-cmd-doc-list (&optional (group :cmd))
166 "Return list of all commands"
168 (maphash (lambda (k v)
170 (eql (length k) (length (cmd-table-entry-name v)))
171 (eq (cmd-table-entry-group v) group))
172 (push (list k (cmd-table-entry-desc v)) cmds)))
174 (sort cmds #'string-lessp :key #'car)))
176 (defun cd-cmd (&optional string-dir)
178 ((or (zerop (length string-dir))
179 (string= string-dir "~"))
180 (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
182 (let ((new (truename string-dir)))
183 (when (pathnamep new)
184 (setf cl:*default-pathname-defaults* new)))))
185 (format t "~A~%" (namestring cl:*default-pathname-defaults*))
189 (format t "Lisp's current working directory is ~s.~%"
190 (namestring cl:*default-pathname-defaults*))
193 (defun trace-cmd (&rest args)
195 (format t "~A~%" (eval (apply #'sb-debug::expand-trace args)))
196 (format t "~A~%" (sb-debug::%list-traced-funs)))
199 (defun untrace-cmd (&rest args)
203 (sb-int:collect ((res))
204 (let ((current args))
206 (unless current (return))
207 (let ((name (pop current)))
208 (res (if (eq name :function)
209 `(sb-debug::untrace-1 ,(pop current))
210 `(sb-debug::untrace-1 ',name))))))
211 `(progn ,@(res) t))))
212 (format t "~A~%" (eval (sb-debug::untrace-all))))
215 (defun exit-cmd (&optional (status 0))
216 (quit :unix-status status)
219 (defun package-cmd (&optional pkg)
222 (format t "The ~A package is current.~%" (package-name cl:*package*)))
223 ((null (find-package (write-to-string pkg)))
224 (format t "Unknown package: ~A.~%" pkg))
226 (setf cl:*package* (find-package (write-to-string pkg)))))
229 (defun string-to-list-skip-spaces (str)
230 "Return a list of strings, delimited by spaces, skipping spaces."
231 (loop for i = 0 then (1+ j)
232 as j = (position #\space str :start i)
233 when (not (char= (char str i) #\space))
234 collect (subseq str i j) while j))
236 (defun ld-cmd (string-files)
237 (dolist (arg (string-to-list-skip-spaces string-files))
238 (format t "loading ~a~%" arg)
242 (defun cf-cmd (string-files)
243 (dolist (arg (string-to-list-skip-spaces string-files))
248 "Return if x and y are numbers, and x > y"
249 (and (numberp x) (numberp y) (> x y)))
251 (defun newer-file-p (file1 file2)
252 "Is file1 newer (written later than) file2?"
253 (>-num (if (probe-file file1) (file-write-date file1))
254 (if (probe-file file2) (file-write-date file2))))
256 (defun compile-file-as-needed (src-path)
257 "Compiles a file if needed, returns path."
258 (let ((dest-path (compile-file-pathname src-path)))
259 (when (or (not (probe-file dest-path))
260 (newer-file-p src-path dest-path))
261 (ensure-directories-exist dest-path)
262 (compile-file src-path :output-file dest-path))
265 ;;;; implementation of commands
267 (defun cload-cmd (string-files)
268 (dolist (arg (string-to-list-skip-spaces string-files))
269 (load (compile-file-as-needed arg)))
272 (defun inspect-cmd (arg)
273 (eval `(inspect ,arg))
276 (defun describe-cmd (&rest args)
278 (eval `(describe ,arg)))
281 (defun macroexpand-cmd (arg)
282 (pprint (macroexpand arg))
285 (defun history-cmd ()
286 (let ((n (length *history*)))
290 (let ((hist (nth (- n i 1) *history*)))
291 (format t "~3A ~A~%" (user-cmd-hnum hist) (user-cmd-input hist)))))
294 (defun help-cmd (&optional cmd)
297 (let ((cmd-entry (find-cmd cmd)))
299 (format t "Documentation for ~A: ~A~%"
300 (cmd-table-entry-name cmd-entry)
301 (cmd-table-entry-desc cmd-entry)))))
303 (format t "~13A ~a~%" "Command" "Description")
304 (format t "------------- -------------~%")
305 (dolist (doc-entry (get-cmd-doc-list :cmd))
306 (format t "~13A ~A~%" (car doc-entry) (cadr doc-entry)))))
310 (let ((doc-entries (get-cmd-doc-list :alias)))
311 (typecase doc-entries
313 (format t "~13A ~a~%" "Alias" "Description")
314 (format t "------------- -------------~%")
315 (dolist (doc-entry doc-entries)
316 (format t "~13A ~A~%" (car doc-entry) (cadr doc-entry))))
318 (format t "No aliases are defined~%"))))
321 (defun shell-cmd (string-arg)
322 (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
323 :input nil :output *trace-output*)
326 (defun pushd-cmd (string-arg)
327 (push string-arg *dir-stack*)
333 (let ((dir (pop *dir-stack*)))
335 (format t "No directory on stack to pop.~%"))
339 (dolist (dir *dir-stack*)
340 (format t "~a~%" dir))
343 ;;;; dispatch table for commands
346 '(("aliases" 3 alias-cmd "show aliases")
347 ("cd" 2 cd-cmd "change default diretory" :parsing :string)
348 ("ld" 2 ld-cmd "load a file" :parsing :string)
349 ("cf" 2 cf-cmd "compile file" :parsing :string)
350 ("cload" 2 cload-cmd "compile if needed and load file"
352 ("describe" 2 describe-cmd "describe an object")
353 ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
354 ("package" 2 package-cmd "change current package")
355 ("exit" 2 exit-cmd "exit sbcl")
356 ("help" 2 help-cmd "print this help")
357 ("history" 3 history-cmd "print the recent history")
358 ("inspect" 2 inspect-cmd "inspect an object")
359 ("pwd" 3 pwd-cmd "print current directory")
360 ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
361 ("popd" 2 popd-cmd "pop directory from stack")
362 ("trace" 2 trace-cmd "trace a function")
363 ("untrace" 4 untrace-cmd "untrace a function")
364 ("dirs" 2 dirs-cmd "show directory stack")
365 ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string))))
366 (dolist (cmd cmd-table)
367 (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
368 (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
370 ;;;; machinery for aliases
372 (defsetf alias (name) (user-func)
375 (make-cte (quote ,name) ,user-func "" nil :alias))
378 (defmacro alias (name-param args &rest body)
382 (name (if (atom name-param)
385 (when (consp name-param)
386 (dolist (param (cdr name-param))
389 (eq param :case-sensitive)
391 (setq parsing param))
395 (setq abbr-index param)))))
398 (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias)
403 (defun remove-alias (&rest aliases)
405 (remove-all (not (null (find :all aliases)))))
406 (unless remove-all ;; ensure all alias are strings
408 (loop for alias in aliases
414 (symbol-name alias))))))
417 (when (eq (cmd-table-entry-group cmd) :alias)
422 (let ((klen (length key)))
423 (and (>= (length alias) klen)
424 (string-equal (subseq alias 0 klen)
425 (subseq key 0 klen)))))
430 (remhash key *cmd-table-hash*))
433 ;;;; low-level reading/parsing functions
435 ;;; Skip white space (but not #\NEWLINE), and peek at the next
437 (defun peek-char-non-whitespace (&optional stream)
438 (do ((char (peek-char nil stream nil *eof-marker*)
439 (peek-char nil stream nil *eof-marker*)))
440 ((not (whitespace-char-not-newline-p char)) char)
443 (defun string-trim-whitespace (str)
444 (string-trim '(#\space #\tab #\return)
447 (defun whitespace-char-not-newline-p (x)
449 (or (char= x #\space)
451 (char= x #\return))))
453 ;;;; linking into SBCL hooks
455 (defun repl-prompt-fun (stream)
458 (if (functionp *prompt*)
459 (write-string (funcall *prompt* (prompt-package-name) *cmd-number*)
461 (format stream *prompt* (prompt-package-name) *cmd-number*)))
463 ;;; If USER-CMD is to be processed as something magical (not an
464 ;;; ordinary eval-and-print-me form) then do so and return non-NIL.
465 (defun execute-as-acl-magic (user-cmd input-stream output-stream)
466 ;; kludgity kludge kludge kludge ("and then a miracle occurs")
468 ;; This is a really sloppy job of smashing KMR's code (what he
469 ;; called DEFUN REP-ONE-CMD) onto DB's hook ideas, not even doing
470 ;; the basics like passing INPUT-STREAM and OUTPUT-STREAM into the
471 ;; KMR code. A real implementation might want to do rather better.
472 (cond ((eq user-cmd *eof-cmd*)
477 t) ; Yup, we knew how to handle that.
478 ((eq user-cmd *null-cmd*)
481 ((functionp (user-cmd-func user-cmd))
482 (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd))
483 (add-to-history user-cmd)
487 (add-to-history user-cmd)
488 nil))) ; nope, not in my job description
490 (defun repl-read-form-fun (input-stream output-stream)
491 ;; Pick off all the leading ACL magic commands, then return a normal
493 (loop for user-cmd = (read-cmd input-stream) do
494 (if (execute-as-acl-magic user-cmd input-stream output-stream)
496 (repl-prompt-fun output-stream)
497 (force-output output-stream))
498 (return (user-cmd-input user-cmd)))))
500 (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
501 sb-int:*repl-read-form-fun* #'repl-read-form-fun)