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