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:defpackage :sb-aclrepl
  11   (:use :cl :sb-ext)
  12   (:export #:*prompt* #:*exit-on-eof* #:*max-history*
  13            #:*use-short-package-name* #:*command-char*
  14            #:alias))
  15
  16 (cl:in-package :sb-aclrepl)
  17
  18 (defstruct user-cmd
  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
  24
  25 (defstruct break-data
  26   ;; numeric break level
  27   level
  28   ;; inspect data for a break level
  29   inspect
  30   ;; T when break initiated by an inspect
  31   inspect-initiated
  32   ;; restarts list for a break level
  33   restarts
  34   ;; T if break level is a continuable break
  35   continuable)
  36
  37 ;;; cmd table entry
  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
  45
  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
  62   "History list")
  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")
  71
  72 (declaim (type list *history*))
  73
  74 (defvar *eof-marker* :eof)
  75 (defvar *eof-cmd* (make-user-cmd :func :eof))
  76 (defvar *null-cmd* (make-user-cmd :func :null-cmd))
  77
  78 (defparameter *cmd-table-hash*
  79   (make-hash-table :size 30 :test #'equal))
  80
  81 ;; Set up binding for multithreading
  82
  83 (let ((*prompt* #.*default-prompt*)
  84       (*use-short-package-name* t)
  85       (*dir-stack* nil)
  86       (*command-char* #\:)
  87       (*max-history* 24)
  88       (*exit-on-eof* t)
  89       (*history* nil)
  90       (*cmd-number* 1)
  91       (*repl-output* nil)
  92       (*repl-input* nil)
  93       (*break-stack* (list (make-break-data :level 0)))
  94       )
  95
  96 (defun prompt-package-name ()
  97   (if *use-short-package-name*
  98       (car (sort (append
  99                   (package-nicknames cl:*package*)
 100                   (list (package-name cl:*package*)))
 101                  (lambda (a b) (< (length a) (length b)))))
 102       (package-name cl:*package*)))
 103
 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)
 107            (case parsing
 108              (:string
 109               (if (zerop (length args-string))
 110                   nil
 111                   (list args-string)))
 112              (t
 113               (let ((string-stream (make-string-input-stream args-string))
 114                     (eof (cons nil *eof-marker*))) ;new cons for eq uniqueness
 115                 (loop as arg = (read string-stream nil eof)
 116                       until (eq arg eof)
 117                       collect arg))))))
 118     (let ((next-char (peek-char-non-whitespace input-stream)))
 119       (cond
 120         ((eql next-char *command-char*)
 121          (let* ((line (string-trim-whitespace (read-line input-stream)))
 122                 (first-space-pos (position #\space line))
 123                 (cmd-string (subseq line 1 first-space-pos))
 124                 (cmd-args-string
 125                  (if first-space-pos
 126                      (string-trim-whitespace (subseq line first-space-pos))
 127                      "")))
 128            (declare (string line))
 129            (if (numberp (read-from-string cmd-string))
 130                (let ((cmd (get-history (read-from-string cmd-string))))
 131                  (if (eq cmd *null-cmd*)
 132                      (make-user-cmd :func :history-error
 133                                     :input (read-from-string cmd-string))
 134                      (make-user-cmd :func (user-cmd-func cmd)
 135                                     :input (user-cmd-input cmd)
 136                                     :args (user-cmd-args cmd)
 137                                     :hnum *cmd-number*)))
 138                (let ((cmd-entry (find-cmd cmd-string)))
 139                  (if cmd-entry
 140                      (make-user-cmd :func (cmd-table-entry-func cmd-entry)
 141                                     :input line
 142                                     :args (parse-args
 143                                            (cmd-table-entry-parsing cmd-entry)
 144                                            cmd-args-string)
 145                                     :hnum *cmd-number*)
 146                      (make-user-cmd :func :cmd-error
 147                                     :input cmd-string)
 148                      )))))
 149         ((eql next-char #\newline)
 150          (read-char input-stream)
 151          *null-cmd*)
 152       (t
 153        (let* ((eof (cons nil *eof-marker*))
 154               (form (read input-stream nil eof)))
 155          (if (eq form eof)
 156              *eof-cmd*
 157              (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
 158
 159 (defun make-cte (name-param func desc parsing group abbr-len)
 160   (let ((name (etypecase name-param
 161                 (string
 162                  name-param)
 163                 (symbol
 164                  (string-downcase (write-to-string name-param))))))
 165     (make-cmd-table-entry :name name :func func :desc desc
 166                           :parsing parsing :group group
 167                           :abbr-len (if abbr-len
 168                                         abbr-len
 169                                         (length name)))))
 170
 171 (defun %add-entry (cmd &optional abbr-len)
 172   (let* ((name (cmd-table-entry-name cmd))
 173          (alen (if abbr-len
 174                    abbr-len
 175                    (length name))))
 176     (dotimes (i (length name))
 177       (when (>= i (1- alen))
 178         (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
 179               cmd)))))
 180
 181 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
 182   (%add-entry
 183    (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len)
 184    abbr-len))
 185
 186 (defun find-cmd (cmdstr)
 187   (gethash (string-downcase cmdstr) *cmd-table-hash*))
 188
 189 (defun user-cmd= (c1 c2)
 190   "Returns T if two user commands are equal"
 191   (and (eq (user-cmd-func c1) (user-cmd-func c2))
 192        (equal (user-cmd-args c1) (user-cmd-args c2))
 193        (equal (user-cmd-input c1) (user-cmd-input c2))))
 194
 195 (defun add-to-history (cmd)
 196   (unless (and *history* (user-cmd= cmd (car *history*)))
 197     (when (>= (length *history*) *max-history*)
 198       (setq *history* (nbutlast *history* (+ (length *history*) *max-history* 1))))
 199     (push cmd *history*)
 200     (incf *cmd-number*)))
 201
 202 (defun get-history (n)
 203   (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
 204     (if cmd
 205         cmd
 206         *null-cmd*)))
 207
 208 (defun get-cmd-doc-list (&optional (group :cmd))
 209   "Return list of all commands"
 210   (let ((cmds '()))
 211     (maphash (lambda (k v)
 212                (when (and
 213                       (= (length k) (length (cmd-table-entry-name v)))
 214                       (eq (cmd-table-entry-group v) group))
 215                  (push (list k
 216                              (if (= (cmd-table-entry-abbr-len v)
 217                                     (length k))
 218                                   ""
 219                                   (subseq k 0 (cmd-table-entry-abbr-len v)))
 220                              (cmd-table-entry-desc v)) cmds)))
 221              *cmd-table-hash*)
 222     (sort cmds #'string-lessp :key #'car)))
 223
 224 (defun cd-cmd (&optional string-dir)
 225   (cond
 226     ((or (zerop (length string-dir))
 227          (string= string-dir "~"))
 228      (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
 229     (t
 230      (let ((new (truename string-dir)))
 231        (when (pathnamep new)
 232          (setf cl:*default-pathname-defaults* new)))))
 233   (format *repl-output* "~A~%" (namestring cl:*default-pathname-defaults*))
 234   (values))
 235
 236 (defun pwd-cmd ()
 237   (format *repl-output* "Lisp's current working directory is ~s.~%"
 238           (namestring cl:*default-pathname-defaults*))
 239   (values))
 240
 241 (defun trace-cmd (&rest args)
 242   (if args
 243       (format *repl-output* "~A~%" (eval (sb-debug::expand-trace args)))
 244       (format *repl-output* "~A~%" (sb-debug::%list-traced-funs)))
 245   (values))
 246
 247 (defun untrace-cmd (&rest args)
 248   (if args
 249       (format *repl-output* "~A~%"
 250               (eval
 251                (sb-int:collect ((res))
 252                 (let ((current args))
 253                   (loop
 254                    (unless current (return))
 255                    (let ((name (pop current)))
 256                      (res (if (eq name :function)
 257                               `(sb-debug::untrace-1 ,(pop current))
 258                               `(sb-debug::untrace-1 ',name))))))
 259                 `(progn ,@(res) t))))
 260       (format *repl-output* "~A~%" (eval (sb-debug::untrace-all))))
 261   (values))
 262
 263 #+sb-thread
 264 (defun thread-pids ()
 265   "Return a list of the pids for all threads"
 266   (let ((offset (* 4 sb-vm::thread-pid-slot)))
 267     (sb-thread::mapcar-threads
 268      #'(lambda (sap) (sb-sys:sap-ref-32 sap offset)))))
 269
 270 #+sb-thread
 271 (defun other-thread-pids ()
 272   "Returns a list of pids for all threads except the current process"
 273   (delete (sb-thread:current-thread-id) (thread-pids) :test #'eql))
 274
 275 (defun exit-cmd (&optional (status 0))
 276   #+sb-thread
 277   (let ((other-pids (other-thread-pids)))
 278     (when other-pids
 279       (format *repl-output* "There exists the following processes~%")
 280       (format *repl-output* "~{~5d~%~}" other-pids)
 281       (format *repl-output* "Do you want to exit lisp anyway [n]? ")
 282       (force-output *repl-output*)
 283       (let ((input (string-trim-whitespace (read-line *repl-input*))))
 284         (if (and (plusp (length input))
 285                  (or (char= #\y (char input 0))
 286                      (char= #\Y (char input 0))))
 287             ;; loop in case more threads get created while trying to exit
 288             (do ((pids other-pids (other-thread-pids)))
 289                 ((eq nil pids))
 290               (map nil #'sb-thread:destroy-thread pids)
 291               (sleep 0.2))
 292             (return-from exit-cmd)))))
 293   (quit :unix-status status)
 294   (values))
 295
 296 (defun package-cmd (&optional pkg)
 297   (cond
 298     ((null pkg)
 299      (format *repl-output* "The ~A package is current.~%"
 300              (package-name cl:*package*)))
 301     ((null (find-package (write-to-string pkg)))
 302      (format *repl-output* "Unknown package: ~A.~%" pkg))
 303     (t
 304      (setf cl:*package* (find-package (write-to-string pkg)))))
 305   (values))
 306
 307 (defun string-to-list-skip-spaces (str)
 308   "Return a list of strings, delimited by spaces, skipping spaces."
 309   (declare (type (or null string) str))
 310   (when str
 311     (loop for i = 0 then (1+ j)
 312           as j = (position #\space str :start i)
 313           when (not (char= (char str i) #\space))
 314           collect (subseq str i j) while j)))
 315
 316 (let ((last-files-loaded nil))
 317   (defun ld-cmd (&optional string-files)
 318     (if string-files
 319         (setq last-files-loaded string-files)
 320         (setq string-files last-files-loaded))
 321     (dolist (arg (string-to-list-skip-spaces string-files))
 322       (let ((file
 323              (if (string= arg "~/" :end1 1 :end2 1)
 324                  (merge-pathnames (parse-namestring
 325                                    (string-left-trim "~/" arg))
 326                                   (user-homedir-pathname))
 327                  arg)))
 328         (format *repl-output* "loading ~S~%" file)
 329         (load file))))
 330   (values))
 331
 332 (defun cf-cmd (string-files)
 333   (when string-files
 334     (dolist (arg (string-to-list-skip-spaces string-files))
 335       (compile-file arg)))
 336   (values))
 337
 338 (defun >-num (x y)
 339   "Return if x and y are numbers, and x > y"
 340   (and (numberp x) (numberp y) (> x y)))
 341
 342 (defun newer-file-p (file1 file2)
 343   "Is file1 newer (written later than) file2?"
 344   (>-num (if (probe-file file1) (file-write-date file1))
 345          (if (probe-file file2) (file-write-date file2))))
 346
 347 (defun compile-file-as-needed (src-path)
 348   "Compiles a file if needed, returns path."
 349   (let ((dest-path (compile-file-pathname src-path)))
 350     (when (or (not (probe-file dest-path))
 351               (newer-file-p src-path dest-path))
 352       (ensure-directories-exist dest-path)
 353       (compile-file src-path :output-file dest-path))
 354     dest-path))
 355 \f
 356 ;;;; implementation of commands
 357
 358 (defun apropos-cmd (string)
 359   (apropos (string-upcase string))
 360   (values))
 361
 362 (let ((last-files-loaded nil))
 363   (defun cload-cmd (&optional string-files)
 364     (if string-files
 365         (setq last-files-loaded string-files)
 366         (setq string-files last-files-loaded))
 367     (dolist (arg (string-to-list-skip-spaces string-files))
 368       (format *repl-output* "loading ~a~%" arg)
 369       (load (compile-file-as-needed arg)))
 370     (values)))
 371
 372 (defun inspect-cmd (arg)
 373   (inspector arg nil *repl-output*)
 374   (values))
 375
 376 (defun istep-cmd (&optional arg-string)
 377   (istep (string-to-list-skip-spaces arg-string) *repl-output*)
 378   (values))
 379
 380 (defun describe-cmd (&rest args)
 381   (dolist (arg args)
 382     (eval `(describe ,arg)))
 383   (values))
 384
 385 (defun macroexpand-cmd (arg)
 386   (pprint (macroexpand arg) *repl-output*)
 387   (values))
 388
 389 (defun history-cmd ()
 390   (let ((n (length *history*)))
 391     (declare (fixnum n))
 392     (dotimes (i n)
 393       (declare (fixnum i))
 394       (let ((hist (nth (- n i 1) *history*)))
 395         (format *repl-output* "~3A " (user-cmd-hnum hist))
 396         (if (stringp (user-cmd-input hist))
 397             (format *repl-output* "~A~%" (user-cmd-input hist))
 398             (format *repl-output* "~W~%" (user-cmd-input hist))))))
 399   (values))
 400
 401 (defun help-cmd (&optional cmd)
 402   (cond
 403     (cmd
 404      (let ((cmd-entry (find-cmd cmd)))
 405        (if cmd-entry
 406            (format *repl-output* "Documentation for ~A: ~A~%"
 407                    (cmd-table-entry-name cmd-entry)
 408                    (cmd-table-entry-desc cmd-entry)))))
 409     (t
 410      (format *repl-output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
 411      (format *repl-output* "~11A ~4A ~A~%" "<n>" ""
 412              "re-execute <n>th history command")
 413      (dolist (doc-entry (get-cmd-doc-list :cmd))
 414        (format *repl-output* "~11A ~4A ~A~%" (first doc-entry)
 415                (second doc-entry) (third doc-entry)))))
 416   (values))
 417
 418 (defun alias-cmd ()
 419   (let ((doc-entries (get-cmd-doc-list :alias)))
 420     (typecase doc-entries
 421       (cons
 422        (format *repl-output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
 423        (dolist (doc-entry doc-entries)
 424          (format *repl-output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
 425       (t
 426        (format *repl-output* "No aliases are defined~%"))))
 427   (values))
 428
 429 (defun shell-cmd (string-arg)
 430   (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
 431                       :input nil :output *repl-output*)
 432   (values))
 433
 434 (defun pushd-cmd (string-arg)
 435   (push string-arg *dir-stack*)
 436   (cd-cmd *repl-output* string-arg)
 437   (values))
 438
 439 (defun popd-cmd ()
 440   (if *dir-stack*
 441       (let ((dir (pop *dir-stack*)))
 442         (cd-cmd dir))
 443       (format *repl-output* "No directory on stack to pop.~%"))
 444   (values))
 445
 446 (defun pop-cmd (&optional (n 1))
 447   (let ((new-level (- (length *break-stack*) n 1)))
 448     (when (minusp new-level)
 449       (setq new-level 0))
 450     (dotimes (i (- (length *break-stack*) new-level 1))
 451       (pop *break-stack*)))
 452   ;; Find inspector
 453   (do* ((i (1- (length *break-stack*)) (1- i))
 454         (found nil))
 455        ((or found (minusp i)))
 456     (let ((inspect (break-data-inspect (nth i *break-stack*))))
 457       (when inspect
 458         (set-current-inspect inspect)
 459         (setq found t))))
 460   (values))
 461
 462 (defun continue-cmd (n)
 463   (let ((restarts (break-data-restarts (car *break-stack*))))
 464     (if restarts
 465         (if (< -1 n (length restarts))
 466             (progn
 467               (invoke-restart-interactively (nth n restarts))
 468               )
 469             (format *repl-output* "~&There is no such restart"))
 470         (format *repl-output* "~&There are no restarts"))))
 471
 472 (defun error-cmd ()
 473   )
 474
 475 (defun current-cmd ()
 476   )
 477
 478 (defun frame-cmd ()
 479   )
 480
 481 (defun zoom-cmd ()
 482   )
 483
 484 (defun local-cmd (&optional var)
 485   (declare (ignore var))
 486   )
 487
 488 (defun processes-cmd ()
 489   #+sb-thread
 490   (let ((pids (thread-pids))
 491         (current-pid (sb-thread:current-thread-id)))
 492     (dolist (pid pids)
 493       (format *repl-output* "~&~D" pid)
 494       (when (= pid current-pid)
 495         (format *repl-output* " [current listener]"))))
 496   #-sb-thread
 497   (format *repl-output* "~&Threads are not supported in this version of sbcl")
 498   (values))
 499
 500 (defun kill-cmd (&rest selected-pids)
 501   #+sb-thread
 502   (let ((pids (thread-pids)))
 503     (dolist (selected-pid selected-pids)
 504       (if (find selected-pid pids :test #'eql)
 505           (progn
 506             (sb-thread:destroy-thread selected-pid)
 507             (format *repl-output* "~&Thread ~A destroyed" selected-pid))
 508           (format *repl-output* "~&No thread ~A exists" selected-pid))))
 509   #-sb-thread
 510   (declare (ignore selected-pids))
 511   #-sb-thread
 512   (format *repl-output* "~&Threads are not supported in this version of sbcl")
 513   (values))
 514
 515 (defun signal-cmd (signal &rest selected-pids)
 516   #+sb-thread
 517   (let ((pids (thread-pids)))
 518     (dolist (selected-pid selected-pids)
 519       (if (find selected-pid pids :test #'eql)
 520           (progn
 521             (sb-unix:unix-kill selected-pid signal)
 522             (format *repl-output* "~&Signal ~A sent to thread ~A"
 523                     signal selected-pid))
 524           (format *repl-output* "~&No thread ~A exists" selected-pid))))
 525   #-sb-thread
 526   (declare (ignore signal selected-pids))
 527   #-sb-thread
 528   (format *repl-output* "~&Threads are not supported in this version of sbcl")
 529   (values))
 530
 531 (defun focus-cmd (&optional process)
 532   #-sb-thread
 533   (declare (ignore process))
 534   #+sb-thread
 535   (when process
 536     (format *repl-output* "~&Focusing on next thread waiting waiting for the debugger~%"))
 537   #+sb-thread
 538   (progn
 539     (sb-thread:release-foreground)
 540     (sleep 1))
 541   #-sb-thread
 542   (format *repl-output* "~&Threads are not supported in this version of sbcl")
 543   (values))
 544
 545 (defun reset-cmd ()
 546   (setf *break-stack* (last *break-stack*))
 547   (values))
 548
 549 (defun dirs-cmd ()
 550   (dolist (dir *dir-stack*)
 551     (format *repl-output* "~a~%" dir))
 552   (values))
 553
 554 \f
 555 ;;;; dispatch table for commands
 556
 557 (let ((cmd-table
 558        '(("aliases" 3 alias-cmd "show aliases")
 559          ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
 560          ("cd" 2 cd-cmd "change default diretory" :parsing :string)
 561          ("ld" 2 ld-cmd "load a file" :parsing :string)
 562          ("cf" 2 cf-cmd "compile file" :parsing :string)
 563          ("cload" 2 cload-cmd "compile if needed and load file"
 564           :parsing :string)
 565          #+aclrepl-debugger("current" 3 current-cmd "print the expression for the current stack frame")
 566          #+aclrepl-debugger ("continue" 4 continue-cmd "continue from a continuable error")
 567          ("describe" 2 describe-cmd "describe an object")
 568          ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
 569          ("package" 2 package-cmd "change current package")
 570          #+aclrepl-debugger ("error" 3 error-cmd "print the last error message")
 571          ("exit" 2 exit-cmd "exit sbcl")
 572          #+aclrepl-debugger("frame" 2 frame-cmd "print info about the current frame")
 573          ("help" 2 help-cmd "print this help")
 574          ("history" 3 history-cmd "print the recent history")
 575          ("inspect" 2 inspect-cmd "inspect an object")
 576          ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
 577          #+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes")
 578          #+sb-thread ("signal" 2 signal-cmd "send a signal to processes")
 579          #+sb-thread ("focus" 2 focus-cmd "focus the top level on a process")
 580          #+aclrepl-debugger("local" 3 local-cmd "print the value of a local variable")
 581          ("pwd" 3 pwd-cmd "print current directory")
 582          ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
 583          ("pop" 3 pop-cmd "pop up `n' (default 1) break levels")
 584          ("popd" 4 popd-cmd "pop directory from stack")
 585          #+sb-thread ("processes" 3 processes-cmd "list all processes")
 586          ("reset" 3 reset-cmd "reset to top break level")
 587          ("trace" 2 trace-cmd "trace a function")
 588          ("untrace" 4 untrace-cmd "untrace a function")
 589          ("dirs" 2 dirs-cmd "show directory stack")
 590          ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string)
 591          #+aclrepl-debugger ("zoom" 2 zoom-cmd "print the runtime stack")
 592          )))
 593   (dolist (cmd cmd-table)
 594     (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
 595       (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
 596 \f
 597 ;;;; machinery for aliases
 598
 599 (defsetf alias (name &key abbr-len description) (user-func)
 600   `(progn
 601     (%add-entry
 602      (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len))
 603     (quote ,name)))
 604
 605 (defmacro alias (name-param args &rest body)
 606   (let ((parsing nil)
 607         (desc "")
 608         (abbr-index nil)
 609         (name (if (atom name-param)
 610                   name-param
 611                   (car name-param))))
 612     (when (consp name-param)
 613      (dolist (param (cdr name-param))
 614         (cond
 615           ((or
 616             (eq param :case-sensitive)
 617             (eq param :string))
 618            (setq parsing param))
 619           ((stringp param)
 620            (setq desc param))
 621           ((numberp param)
 622            (setq abbr-index param)))))
 623     `(progn
 624       (%add-entry
 625        (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index
 626                                                                                (1+ ,abbr-index)))
 627        ,abbr-index)
 628       ,name)))
 629
 630
 631 (defun remove-alias (&rest aliases)
 632   (declare (list aliases))
 633   (let ((keys '())
 634         (remove-all (not (null (find :all aliases)))))
 635     (unless remove-all  ;; ensure all alias are strings
 636       (setq aliases
 637             (loop for alias in aliases
 638                   collect
 639                   (etypecase alias
 640                     (string
 641                      alias)
 642                     (symbol
 643                      (symbol-name alias))))))
 644     (maphash
 645      (lambda (key cmd)
 646        (when (eq (cmd-table-entry-group cmd) :alias)
 647          (if remove-all
 648              (push key keys)
 649              (when (some
 650                     (lambda (alias)
 651                       (let ((klen (length key)))
 652                         (and (>= (length alias) klen)
 653                              (string-equal (subseq alias 0 klen)
 654                                            (subseq key 0 klen)))))
 655                     aliases)
 656                (push key keys)))))
 657      *cmd-table-hash*)
 658     (dolist (key keys)
 659       (remhash key *cmd-table-hash*))
 660     keys))
 661 \f
 662 ;;;; low-level reading/parsing functions
 663
 664 ;;; Skip white space (but not #\NEWLINE), and peek at the next
 665 ;;; character.
 666 (defun peek-char-non-whitespace (&optional stream)
 667   (do ((char (peek-char nil stream nil *eof-marker*)
 668              (peek-char nil stream nil *eof-marker*)))
 669       ((not (whitespace-char-not-newline-p char)) char)
 670     (read-char stream)))
 671
 672 (defun string-trim-whitespace (str)
 673   (string-trim '(#\space #\tab #\return)
 674                str))
 675
 676 (defun whitespace-char-not-newline-p (x)
 677   (and (characterp x)
 678        (or (char= x #\space)
 679            (char= x #\tab)
 680            (char= x #\return))))
 681
 682 \f
 683 ;;;; linking into SBCL hooks
 684
 685
 686 (defun repl-prompt-fun (stream)
 687   (let* ((break-data (car *break-stack*))
 688          (break-level (break-data-level break-data)))
 689     (when (zerop break-level)
 690       (setq break-level nil))
 691     #+sb-thread
 692     (let ((lock sb-thread::*session-lock*))
 693       (sb-thread::get-foreground)
 694       (let ((stopped-threads (sb-thread::waitqueue-data lock)))
 695         (when stopped-threads
 696           (format stream "~{~&Thread ~A suspended~}~%" stopped-threads))))
 697     (if (functionp *prompt*)
 698         (write-string (funcall *prompt* break-level
 699                                (break-data-inspect-initiated break-data)
 700                                (break-data-continuable break-data)
 701                                (prompt-package-name) *cmd-number*)
 702                       stream)
 703         (handler-case
 704             (format nil *prompt* break-level
 705                     (break-data-inspect-initiated break-data)
 706                     (break-data-continuable break-data)
 707                     (prompt-package-name) *cmd-number*)
 708           (error ()
 709             (format stream "~&Prompt error>  "))
 710           (:no-error (prompt)
 711             (format stream "~&~A" prompt))))))
 712
 713 (defun process-cmd (user-cmd input-stream output-stream)
 714   ;; Processes a user command. Returns t if the user-cmd was a top-level
 715   ;; command
 716   (cond ((eq user-cmd *eof-cmd*)
 717          (when *exit-on-eof*
 718            (quit))
 719          (format output-stream "EOF~%")
 720          t)
 721         ((eq user-cmd *null-cmd*)
 722          t)
 723         ((eq (user-cmd-func user-cmd) :cmd-error)
 724          (format output-stream "Unknown top-level command: ~s.~%"
 725                  (user-cmd-input user-cmd))
 726          (format output-stream "Type `:help' for the list of commands.~%")
 727          t)
 728         ((eq (user-cmd-func user-cmd) :history-error)
 729          (format output-stream "Input numbered ~d is not on the history list~%"
 730                  (user-cmd-input user-cmd))
 731          t)
 732         ((functionp (user-cmd-func user-cmd))
 733          (add-to-history user-cmd)
 734          (let ((*repl-output* output-stream)
 735                (*repl-input* input-stream))
 736            (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd)))
 737          (fresh-line)
 738          t)
 739         (t
 740          (add-to-history user-cmd)
 741          nil))) ; nope, not in my job description
 742
 743 (defun repl-read-form-fun (input-stream output-stream)
 744   ;; Pick off all the leading ACL magic commands, then return a normal
 745   ;; Lisp form.
 746   (loop for user-cmd = (read-cmd input-stream) do
 747         (if (process-cmd user-cmd input-stream output-stream)
 748             (progn
 749               (funcall sb-int:*repl-prompt-fun* output-stream)
 750               (force-output output-stream))
 751             (return (user-cmd-input user-cmd)))))
 752
 753
 754 (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
 755       sb-int:*repl-read-form-fun* #'repl-read-form-fun)
 756
 757 ;;; Break level processing
 758
 759 ;; use an initial break-level to hold current inspect toplevel at
 760 ;; break-level 0
 761
 762 (defun new-break (&key restarts inspect continuable)
 763   (push
 764    (make-break-data :level (length *break-stack*)
 765                     :restarts restarts
 766                     :inspect inspect
 767                     :inspect-initiated (when inspect t)
 768                     :continuable continuable)
 769    *break-stack*))
 770
 771 (defun set-break-inspect (inspect)
 772   "sets the inspect data for the current break level"
 773   (setf (break-data-inspect (car *break-stack*)) inspect))
 774
 775 ) ;; close special variables bindings
 776