9744e68f37853c0736fa11911a1d4d6257c7f31a
[sbcl.git] / contrib / sb-aclrepl / repl.lisp
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*.
5 ;;;;
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>.
9
10 (cl:in-package :sb-aclrepl)
11
12 (defstruct user-cmd
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
18
19
20 ;;; cmd table entry
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
28   
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
46   "History list")
47 (defparameter *cmd-number* 1
48   "Number of the next command")
49
50 (defvar *input*)
51 (defvar *output*)
52
53 (declaim (type list *history*))
54
55 (defvar *eof-marker* :eof)
56 (defvar *eof-cmd* (make-user-cmd :func :eof))
57 (defvar *null-cmd* (make-user-cmd :func :null-cmd))
58
59 (defparameter *cmd-table-hash*
60   (make-hash-table :size 30 :test #'equal))
61
62 (defun prompt-package-name ()
63   (if *use-short-package-name*
64       (car (sort (append
65                   (package-nicknames cl:*package*)
66                   (list (package-name cl:*package*)))
67                  (lambda (a b) (< (length a) (length b)))))
68       (package-name cl:*package*)))
69
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))
73          (cmd (cond
74                 ((eql *command-char* next-char)
75                  (dispatch-command-line input-stream))
76                 ((eql #\newline next-char)
77                  (read-char input-stream)
78                  *null-cmd*)
79                 ((eql :eof next-char)
80                  *eof-cmd*)
81                 (t
82                  (let* ((eof (cons nil *eof-marker*))
83                         (form (read input-stream nil eof)))
84                    (if (eq form eof)
85                        *eof-cmd*
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)
89         cmd)))
90
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))
96          (cmd-args-string
97           (if first-space-pos
98               (string-trim-whitespace (subseq line first-space-pos))
99               "")))
100     (declare (simple-string line))
101     (cond
102       ((or (zerop (length cmd-string))
103            (whitespace-char-p (char cmd-string 0)))
104        *null-cmd*)
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))
111       (t
112        (process-cmd-text cmd-string line cmd-args-string)))))
113
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)
118                             cmd-string
119                             (subseq cmd-string 1)))
120          (is-minus (char= first-char #\-))
121          (raw-number (read-from-string number-string))
122          (number (if is-minus
123                      (- *cmd-number* raw-number)
124                      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
129                                                     cmd-string))))
130     (maybe-return-history-cmd cmd cmd-args-string)))
131
132 (defun maybe-return-history-cmd (cmd cmd-args-string)
133   (format *output* "~A~%" (user-cmd-input cmd))
134   (let ((dont-redo
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")
143                   t))
144              (when line
145                (format *output* "Type \"y\" for yes or \"n\" for no.~%"))
146              (format *output* "redo? [y] ")
147              (force-output *output*)))))
148     (if dont-redo
149         *null-cmd*
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*))))
154
155
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)
161                              input
162                              (write-to-string input))))
163       (when (search cmd-string string-input :test #'string-equal)
164         (return-from find-history-matching-pattern his)))))
165
166 (defun process-history-search (pattern cmd-args-string)
167   (let ((cmd (find-history-matching-pattern pattern)))
168     (unless cmd
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)))
172
173
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)
177            (case parsing
178              (:string
179               (if (zerop (length args-string))
180                   nil
181                   (list args-string)))
182              (t
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)
186                       until (eq arg eof)
187                       collect arg))))))
188     (let ((cmd-entry (find-cmd cmd-string)))
189       (unless cmd-entry
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)
193                      :input line
194                      :args (parse-args (cmd-table-entry-parsing cmd-entry)
195                                        cmd-args-string)
196                      :hnum *cmd-number*))))
197   
198 (defun make-cte (name-param func desc parsing group abbr-len)
199   (let ((name (etypecase name-param
200                 (string
201                  name-param)
202                 (symbol
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
207                                         abbr-len
208                                         (length name)))))
209
210 (defun %add-entry (cmd &optional abbr-len)
211   (let* ((name (cmd-table-entry-name cmd))
212          (alen (if abbr-len
213                    abbr-len
214                    (length name))))
215     (dotimes (i (length name))
216       (when (>= i (1- alen))
217         (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
218               cmd)))))
219
220 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
221   (%add-entry
222    (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len)
223    abbr-len))
224    
225 (defun find-cmd (cmdstr)
226   (gethash (string-downcase cmdstr) *cmd-table-hash*))
227
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))))
233
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*)))))
239     (push cmd *history*)
240     (incf *cmd-number*)))
241
242 (defun get-history (n)
243   (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
244     (if cmd
245         cmd
246         *null-cmd*)))
247
248 (defun get-cmd-doc-list (&optional (group :cmd))
249   "Return list of all commands"
250   (let ((cmds '()))
251     (maphash (lambda (k v)
252                (when (and
253                       (= (length k) (length (cmd-table-entry-name v)))
254                       (eq (cmd-table-entry-group v) group))
255                  (push (list k
256                              (if (= (cmd-table-entry-abbr-len v)
257                                     (length k))
258                                   ""
259                                   (subseq k 0 (cmd-table-entry-abbr-len v)))
260                              (cmd-table-entry-desc v)) cmds)))
261              *cmd-table-hash*)
262     (sort cmds #'string-lessp :key #'car)))
263
264 (defun cd-cmd (&optional string-dir)
265   (cond
266     ((or (zerop (length string-dir))
267          (string= string-dir "~"))
268      (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
269     (t
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*))
274   (values))
275
276 (defun pwd-cmd ()
277   (format *output* "Lisp's current working directory is ~s.~%"
278           (namestring cl:*default-pathname-defaults*))
279   (values))
280
281 (defun trace-cmd (&rest args)
282   (if args
283       (format *output* "~A~%" (eval (sb-debug::expand-trace args)))
284       (format *output* "~A~%" (sb-debug::%list-traced-funs)))
285   (values))
286
287 (defun untrace-cmd (&rest args)
288   (if args
289       (format *output* "~A~%"
290               (eval
291                (sb-int:collect ((res))
292                 (let ((current args))
293                   (loop
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))))
301   (values))
302
303 #+sb-thread
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)))))
309
310 #+sb-thread
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))
314
315 (defun exit-cmd (&optional (status 0))
316   #+sb-thread
317   (let ((other-pids (other-thread-pids)))
318     (when other-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)))
329                 ((eq nil pids))
330               (map nil #'sb-thread:destroy-thread pids)
331               (sleep 0.2))
332             (return-from exit-cmd)))))
333   (sb-ext:quit :unix-status status)
334   (values))
335
336 (defun package-cmd (&optional pkg)
337   (cond
338     ((null 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))
343     (t
344      (setf cl:*package* (find-package (write-to-string pkg)))))
345   (values))
346
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)) 
350   (when 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)))
355
356 (let ((last-files-loaded nil))
357   (defun ld-cmd (&optional string-files)
358     (if 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))
362       (let ((file 
363              (if (string= arg "~/" :end1 1 :end2 1)
364                  (merge-pathnames (parse-namestring
365                                    (string-left-trim "~/" arg))
366                                   (user-homedir-pathname))
367                  arg)))
368         (format *output* "loading ~S~%" file)
369         (load file))))
370   (values))
371
372 (defun cf-cmd (string-files)
373   (when string-files
374     (dolist (arg (string-to-list-skip-spaces string-files))
375       (compile-file arg)))
376   (values))
377
378 (defun >-num (x y)
379   "Return if x and y are numbers, and x > y"
380   (and (numberp x) (numberp y) (> x y)))
381
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))))
386
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))
394     dest-path))
395 \f
396 ;;;; implementation of commands
397
398 (defun apropos-cmd (string)
399   (apropos (string-upcase string))
400   (fresh-line *output*)
401   (values))
402
403 (let ((last-files-loaded nil))
404   (defun cload-cmd (&optional string-files)
405     (if 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)))
411     (values)))
412
413 (defun inspect-cmd (arg)
414   (inspector-fun (eval arg) nil *output*)
415   (values))
416
417 (defun istep-cmd (&optional arg-string)
418   (istep (string-to-list-skip-spaces arg-string) *output*)
419   (values))
420
421 (defun describe-cmd (&rest args)
422   (dolist (arg args)
423     (eval `(describe ,arg)))
424   (values))
425
426 (defun macroexpand-cmd (arg)
427   (pprint (macroexpand arg) *output*)
428   (values))
429
430 (defun history-cmd ()
431   (let ((n (length *history*)))
432     (declare (fixnum n))
433     (dotimes (i n)
434       (declare (fixnum i))
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))))))
440   (values))
441
442 (defun help-cmd (&optional cmd)
443   (cond
444     (cmd
445      (let ((cmd-entry (find-cmd cmd)))
446        (if cmd-entry
447            (format *output* "Documentation for ~A: ~A~%"
448                    (cmd-table-entry-name cmd-entry)
449                    (cmd-table-entry-desc cmd-entry)))))
450     (t
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)))))
457   (values))
458
459 (defun alias-cmd ()
460   (let ((doc-entries (get-cmd-doc-list :alias)))
461     (typecase doc-entries
462       (cons
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))))
466       (t
467        (format *output* "No aliases are defined~%"))))
468   (values))
469
470 (defun shell-cmd (string-arg)
471   (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
472                       :input nil :output *output*)
473   (values))
474
475 (defun pushd-cmd (string-arg)
476   (push string-arg *dir-stack*)
477   (cd-cmd string-arg)
478   (values))
479
480 (defun popd-cmd ()
481   (if *dir-stack*
482       (let ((dir (pop *dir-stack*)))
483         (cd-cmd dir))
484       (format *output* "No directory on stack to pop.~%"))
485   (values))
486
487 (defun pop-cmd (&optional (n 1))
488   (cond
489     (*inspect-break*
490      (throw 'repl-catcher (values :inspect n)))
491     ((plusp *break-level*)
492      (throw 'repl-catcher (values :pop n))))
493   (values))
494
495 (defun bt-cmd (&optional (n most-positive-fixnum))
496   (sb-debug::backtrace n))
497
498 (defun current-cmd ()
499   (sb-debug::describe-debug-command))
500
501 (defun top-cmd ()
502   (sb-debug::frame-debug-command 0))
503
504 (defun bottom-cmd ()
505   (sb-debug::bottom-debug-command))
506
507 (defun up-cmd (&optional (n 1))
508   (dotimes (i n)
509     (if (and sb-debug::*current-frame*
510              (sb-di:frame-up sb-debug::*current-frame*))
511         (sb-debug::up-debug-command)
512         (progn
513           (format *output* "Top of the stack")
514           (return-from up-cmd)))))
515
516 (defun dn-cmd (&optional (n 1))
517   (dotimes (i n)
518     (if (and sb-debug::*current-frame*
519              (sb-di:frame-down sb-debug::*current-frame*))
520         (sb-debug::down-debug-command)
521         (progn
522           (format *output* "Bottom of the stack")
523           (return-from dn-cmd)))))
524
525 (defun continue-cmd (&optional (num 0))
526   ;; don't look at first restart
527   (let ((restarts (compute-restarts)))
528     (if restarts
529         (let ((restart
530                (typecase num
531                  (unsigned-byte
532                   (if (< -1 num (length restarts))
533                       (nth num restarts)
534                       (progn
535                         (format *output* "There is no such restart")
536                         (return-from continue-cmd))))
537                  (symbol
538                   (find num (the list restarts)
539                         :key #'restart-name
540                         :test (lambda (sym1 sym2)
541                                 (string= (symbol-name sym1)
542                                          (symbol-name sym2)))))
543                  (t
544                   (format *output* "~S is invalid as a restart name" num)
545                   (return-from continue-cmd nil)))))
546           (when restart
547             (invoke-restart-interactively restart)))
548     (format *output* "~&There are no restarts"))))
549
550 (defun error-cmd ()
551   (when (plusp *break-level*)
552     (if *inspect-break*
553         (sb-debug::show-restarts (compute-restarts) *output*)
554         (let ((sb-debug::*debug-restarts* (compute-restarts)))
555           (sb-debug::error-debug-command)))))
556
557 (defun frame-cmd ()
558   (sb-debug::print-frame-call sb-debug::*current-frame*))
559
560 (defun zoom-cmd ()
561   )
562
563 (defun local-cmd (&optional var)
564   (declare (ignore var))
565   (sb-debug::list-locals-debug-command))
566
567 (defun processes-cmd ()
568   #+sb-thread
569   (let ((pids (thread-pids))
570         (current-pid (sb-thread:current-thread-id)))
571     (dolist (pid pids)
572       (format *output* "~&~D" pid)
573       (when (= pid current-pid)
574         (format *output* " [current listener]"))))
575   #-sb-thread
576   (format *output* "~&Threads are not supported in this version of sbcl")
577   (values))
578
579 (defun kill-cmd (&rest selected-pids)
580   #+sb-thread
581   (let ((pids (thread-pids)))
582     (dolist (selected-pid selected-pids) 
583       (if (find selected-pid pids :test #'eql)
584           (progn
585             (sb-thread:destroy-thread selected-pid)
586             (format *output* "~&Thread ~A destroyed" selected-pid))
587           (format *output* "~&No thread ~A exists" selected-pid))))
588   #-sb-thread
589   (declare (ignore selected-pids))
590   #-sb-thread
591   (format *output* "~&Threads are not supported in this version of sbcl")
592   (values))
593
594 (defun signal-cmd (signal &rest selected-pids)
595   #+sb-thread
596   (let ((pids (thread-pids)))
597     (dolist (selected-pid selected-pids)
598       (if (find selected-pid pids :test #'eql)
599           (progn
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))))
604   #-sb-thread
605   (declare (ignore signal selected-pids))
606   #-sb-thread
607   (format *output* "~&Threads are not supported in this version of sbcl")
608   (values))
609
610 (defun focus-cmd (&optional process)
611   #-sb-thread
612   (declare (ignore process))
613   #+sb-thread
614   (when process
615     (format *output* "~&Focusing on next thread waiting waiting for the debugger~%"))
616   #+sb-thread
617   (progn
618     (sb-thread:release-foreground)
619     (sleep 1))
620   #-sb-thread
621   (format *output* "~&Threads are not supported in this version of sbcl")
622   (values))
623
624 (defun reset-cmd ()
625   (invoke-restart-interactively (find-restart 'sb-impl::toplevel)))
626
627 (defun dirs-cmd ()
628   (dolist (dir *dir-stack*)
629     (format *output* "~a~%" dir))
630   (values))
631
632 \f
633 ;;;; dispatch table for commands
634
635 (let ((cmd-table
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"
647           :parsing :string)
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")
675          )))
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))))
679 \f
680 ;;;; machinery for aliases
681
682 (defsetf alias (name &key abbr-len description) (user-func)
683   `(progn
684     (%add-entry
685      (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len))
686     (quote ,name)))
687
688 (defmacro alias (name-param args &rest body)
689   (let ((parsing nil)
690         (desc "")
691         (abbr-index nil)
692         (name (if (atom name-param)
693                   name-param
694                   (car name-param))))
695     (when (consp name-param)
696      (dolist (param (cdr name-param))
697         (cond
698           ((or
699             (eq param :case-sensitive)
700             (eq param :string))
701            (setq parsing param))
702           ((stringp param)
703            (setq desc param))
704           ((numberp param)
705            (setq abbr-index param)))))
706     `(progn
707       (%add-entry
708        (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index
709                                                                                (1+ ,abbr-index)))
710        ,abbr-index)
711       ,name)))
712        
713     
714 (defun remove-alias (&rest aliases)
715   (declare (list aliases))
716   (let ((keys '())
717         (remove-all (not (null (find :all aliases)))))
718     (unless remove-all  ;; ensure all alias are strings
719       (setq aliases
720             (loop for alias in aliases
721                   collect
722                   (etypecase alias
723                     (string
724                      alias)
725                     (symbol
726                      (symbol-name alias))))))
727     (maphash
728      (lambda (key cmd)
729        (when (eq (cmd-table-entry-group cmd) :alias)
730          (if remove-all
731              (push key keys)
732              (when (some
733                     (lambda (alias)
734                       (let ((klen (length key)))
735                         (and (>= (length alias) klen)
736                              (string-equal (subseq alias 0 klen)
737                                            (subseq key 0 klen)))))
738                     aliases)
739                (push key keys)))))
740      *cmd-table-hash*)
741     (dolist (key keys)
742       (remhash key *cmd-table-hash*))
743     keys))
744 \f
745 ;;;; low-level reading/parsing functions
746
747 ;;; Skip white space (but not #\NEWLINE), and peek at the next
748 ;;; character.
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)
753     (read-char stream)))
754
755 (defun string-trim-whitespace (str)
756   (string-trim '(#\space #\tab #\return)
757                str))
758
759 (defun whitespace-char-p (x)
760   (and (characterp x)
761        (or (char= x #\space)
762            (char= x #\tab)
763            (char= x #\page)
764            (char= x #\newline)
765            (char= x #\return))))
766
767 (defun whitespace-char-not-newline-p (x)
768   (and (whitespace-char-p x)
769        (not (char= x #\newline))))
770 \f
771 ;;;; linking into SBCL hooks
772
773 (defun repl-prompt-fun (stream)
774   (let ((break-level (when (plusp *break-level*)
775                        *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)
780     (fresh-line stream)
781     (if (functionp *prompt*)
782         (write-string (funcall *prompt*
783                                break-level
784                                frame-number
785                                *inspect-break*
786                                *continuable-break*
787                                (prompt-package-name) *cmd-number*)
788                       stream)
789         (handler-case 
790             (format nil *prompt*
791                     break-level
792                     frame-number
793                     *inspect-break*
794                     *continuable-break*
795                     (prompt-package-name) *cmd-number*)
796           (error ()
797             (format stream "~&Prompt error>  "))
798           (:no-error (prompt)
799             (format stream "~A" prompt))))))
800   
801 (defun process-cmd (user-cmd)
802   ;; Processes a user command. Returns t if the user-cmd was a top-level
803   ;; command
804   (cond ((eq user-cmd *eof-cmd*)
805          (when *exit-on-eof*
806            (sb-ext:quit))
807          (format *output* "EOF~%")
808          t)
809         ((eq user-cmd *null-cmd*)
810          t)
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 `~Ahelp' for the list of commands.~%" *command-char*)
815          t)
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))
819          t)
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))
823          ;;(fresh-line)
824          t)
825         (t
826          (add-to-history user-cmd)
827          nil))) ; nope, not in my job description
828
829 (defun repl-read-form-fun (input output)
830   ;; Pick off all the leading ACL magic commands, then return a normal
831   ;; Lisp form.
832   (let ((*input* input)
833         (*output* output))
834     (loop for user-cmd = (read-cmd *input*) do
835         (if (process-cmd user-cmd)
836             (progn
837               (funcall sb-int:*repl-prompt-fun* *output*)
838               (force-output *output*))
839             (return (user-cmd-input user-cmd))))))
840
841
842 (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
843       sb-int:*repl-read-form-fun* #'repl-read-form-fun)
844
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))
848       (lambda (noprint)
849         (let ((*noprint* noprint))
850           (let (,@(mapcar (lambda (var gvar) `(,var ,gvar)) vars gvars))
851             (unwind-protect
852                  (progn ,@forms)
853               ,@(mapcar (lambda (var gvar) `(setf ,gvar ,var))
854                         vars gvars))))))))
855         
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)))
862
863 (when (boundp 'sb-impl::*repl-fun-generator*)
864   (setq sb-impl::*repl-fun-generator* #'make-repl-fun))