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 all-threads ()
 305   "Return a list of all threads"
 306   (sb-thread:list-all-threads))
 307
 308 #+sb-thread
 309 (defun other-threads ()
 310   "Returns a list of all threads except the current one"
 311   (delete sb-thread:*current-thread* (all-threads)))
 312
 313 (defun exit-cmd (&optional (status 0))
 314   #+sb-thread
 315   (let ((other-threads (other-threads)))
 316     (when other-threads
 317       (format *output* "There exists the following processes~%")
 318       (format *output* "~{~A~%~}" other-threads)
 319       (format *output* "Do you want to exit lisp anyway [n]? ")
 320       (force-output *output*)
 321       (let ((input (string-trim-whitespace (read-line *input*))))
 322         (if (and (plusp (length input))
 323                  (or (char= #\y (char input 0))
 324                      (char= #\Y (char input 0))))
 325             ;; loop in case more threads get created while trying to exit
 326             (do ((threads other-threads (other-threads)))
 327                 ((eq nil threads))
 328               (map nil #'sb-thread:destroy-thread threads)
 329               (sleep 0.2))
 330             (return-from exit-cmd)))))
 331   (sb-ext:quit :unix-status status)
 332   (values))
 333
 334 (defun package-cmd (&optional pkg)
 335   (cond
 336     ((null pkg)
 337      (format *output* "The ~A package is current.~%"
 338              (package-name cl:*package*)))
 339     ((null (find-package (write-to-string pkg)))
 340      (format *output* "Unknown package: ~A.~%" pkg))
 341     (t
 342      (setf cl:*package* (find-package (write-to-string pkg)))))
 343   (values))
 344
 345 (defun string-to-list-skip-spaces (str)
 346   "Return a list of strings, delimited by spaces, skipping spaces."
 347   (declare (type (or null string) str))
 348   (when str
 349     (loop for i = 0 then (1+ j)
 350           as j = (position #\space str :start i)
 351           when (not (char= (char str i) #\space))
 352           collect (subseq str i j) while j)))
 353
 354 (let ((last-files-loaded nil))
 355   (defun ld-cmd (&optional string-files)
 356     (if string-files
 357         (setq last-files-loaded string-files)
 358         (setq string-files last-files-loaded))
 359     (dolist (arg (string-to-list-skip-spaces string-files))
 360       (let ((file
 361              (if (string= arg "~/" :end1 1 :end2 1)
 362                  (merge-pathnames (parse-namestring
 363                                    (string-left-trim "~/" arg))
 364                                   (user-homedir-pathname))
 365                  arg)))
 366         (format *output* "loading ~S~%" file)
 367         (load file))))
 368   (values))
 369
 370 (defun cf-cmd (string-files)
 371   (when string-files
 372     (dolist (arg (string-to-list-skip-spaces string-files))
 373       (compile-file arg)))
 374   (values))
 375
 376 (defun >-num (x y)
 377   "Return if x and y are numbers, and x > y"
 378   (and (numberp x) (numberp y) (> x y)))
 379
 380 (defun newer-file-p (file1 file2)
 381   "Is file1 newer (written later than) file2?"
 382   (>-num (if (probe-file file1) (file-write-date file1))
 383          (if (probe-file file2) (file-write-date file2))))
 384
 385 (defun compile-file-as-needed (src-path)
 386   "Compiles a file if needed, returns path."
 387   (let ((dest-path (compile-file-pathname src-path)))
 388     (when (or (not (probe-file dest-path))
 389               (newer-file-p src-path dest-path))
 390       (ensure-directories-exist dest-path)
 391       (compile-file src-path :output-file dest-path))
 392     dest-path))
 393 \f
 394 ;;;; implementation of commands
 395
 396 (defun apropos-cmd (string)
 397   (apropos (string-upcase string))
 398   (fresh-line *output*)
 399   (values))
 400
 401 (let ((last-files-loaded nil))
 402   (defun cload-cmd (&optional string-files)
 403     (if string-files
 404         (setq last-files-loaded string-files)
 405         (setq string-files last-files-loaded))
 406     (dolist (arg (string-to-list-skip-spaces string-files))
 407       (format *output* "loading ~a~%" arg)
 408       (load (compile-file-as-needed arg)))
 409     (values)))
 410
 411 (defun inspect-cmd (arg)
 412   (inspector-fun (eval arg) nil *output*)
 413   (values))
 414
 415 (defun istep-cmd (&optional arg-string)
 416   (istep (string-to-list-skip-spaces arg-string) *output*)
 417   (values))
 418
 419 (defun describe-cmd (&rest args)
 420   (dolist (arg args)
 421     (eval `(describe ,arg)))
 422   (values))
 423
 424 (defun macroexpand-cmd (arg)
 425   (pprint (macroexpand arg) *output*)
 426   (values))
 427
 428 (defun history-cmd ()
 429   (let ((n (length *history*)))
 430     (declare (fixnum n))
 431     (dotimes (i n)
 432       (declare (fixnum i))
 433       (let ((hist (nth (- n i 1) *history*)))
 434         (format *output* "~3A " (user-cmd-hnum hist))
 435         (if (stringp (user-cmd-input hist))
 436             (format *output* "~A~%" (user-cmd-input hist))
 437             (format *output* "~W~%" (user-cmd-input hist))))))
 438   (values))
 439
 440 (defun help-cmd (&optional cmd)
 441   (cond
 442     (cmd
 443      (let ((cmd-entry (find-cmd cmd)))
 444        (if cmd-entry
 445            (format *output* "Documentation for ~A: ~A~%"
 446                    (cmd-table-entry-name cmd-entry)
 447                    (cmd-table-entry-desc cmd-entry)))))
 448     (t
 449      (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")
 450      (format *output* "~11A ~4A ~A~%" "<n>" ""
 451              "re-execute <n>th history command")
 452      (dolist (doc-entry (get-cmd-doc-list :cmd))
 453        (format *output* "~11A ~4A ~A~%" (first doc-entry)
 454                (second doc-entry) (third doc-entry)))))
 455   (values))
 456
 457 (defun alias-cmd ()
 458   (let ((doc-entries (get-cmd-doc-list :alias)))
 459     (typecase doc-entries
 460       (cons
 461        (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")
 462        (dolist (doc-entry doc-entries)
 463          (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))
 464       (t
 465        (format *output* "No aliases are defined~%"))))
 466   (values))
 467
 468 (defun shell-cmd (string-arg)
 469   (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
 470                       :input nil :output *output*)
 471   (values))
 472
 473 (defun pushd-cmd (string-arg)
 474   (push string-arg *dir-stack*)
 475   (cd-cmd string-arg)
 476   (values))
 477
 478 (defun popd-cmd ()
 479   (if *dir-stack*
 480       (let ((dir (pop *dir-stack*)))
 481         (cd-cmd dir))
 482       (format *output* "No directory on stack to pop.~%"))
 483   (values))
 484
 485 (defun pop-cmd (&optional (n 1))
 486   (cond
 487     (*inspect-break*
 488      (throw 'repl-catcher (values :inspect n)))
 489     ((plusp *break-level*)
 490      (throw 'repl-catcher (values :pop n))))
 491   (values))
 492
 493 (defun bt-cmd (&optional (n most-positive-fixnum))
 494   (sb-debug::backtrace n))
 495
 496 (defun current-cmd ()
 497   (sb-debug::describe-debug-command))
 498
 499 (defun top-cmd ()
 500   (sb-debug::frame-debug-command 0))
 501
 502 (defun bottom-cmd ()
 503   (sb-debug::bottom-debug-command))
 504
 505 (defun up-cmd (&optional (n 1))
 506   (dotimes (i n)
 507     (if (and sb-debug::*current-frame*
 508              (sb-di:frame-up sb-debug::*current-frame*))
 509         (sb-debug::up-debug-command)
 510         (progn
 511           (format *output* "Top of the stack")
 512           (return-from up-cmd)))))
 513
 514 (defun dn-cmd (&optional (n 1))
 515   (dotimes (i n)
 516     (if (and sb-debug::*current-frame*
 517              (sb-di:frame-down sb-debug::*current-frame*))
 518         (sb-debug::down-debug-command)
 519         (progn
 520           (format *output* "Bottom of the stack")
 521           (return-from dn-cmd)))))
 522
 523 (defun continue-cmd (&optional (num 0))
 524   ;; don't look at first restart
 525   (let ((restarts (compute-restarts)))
 526     (if restarts
 527         (let ((restart
 528                (typecase num
 529                  (unsigned-byte
 530                   (if (< -1 num (length restarts))
 531                       (nth num restarts)
 532                       (progn
 533                         (format *output* "There is no such restart")
 534                         (return-from continue-cmd))))
 535                  (symbol
 536                   (find num (the list restarts)
 537                         :key #'restart-name
 538                         :test (lambda (sym1 sym2)
 539                                 (string= (symbol-name sym1)
 540                                          (symbol-name sym2)))))
 541                  (t
 542                   (format *output* "~S is invalid as a restart name" num)
 543                   (return-from continue-cmd nil)))))
 544           (when restart
 545             (invoke-restart-interactively restart)))
 546     (format *output* "~&There are no restarts"))))
 547
 548 (defun error-cmd ()
 549   (when (plusp *break-level*)
 550     (if *inspect-break*
 551         (sb-debug::show-restarts (compute-restarts) *output*)
 552         (let ((sb-debug::*debug-restarts* (compute-restarts)))
 553           (sb-debug::error-debug-command)))))
 554
 555 (defun frame-cmd ()
 556   (sb-debug::print-frame-call sb-debug::*current-frame*))
 557
 558 (defun zoom-cmd ()
 559   )
 560
 561 (defun local-cmd (&optional var)
 562   (declare (ignore var))
 563   (sb-debug::list-locals-debug-command))
 564
 565 (defun processes-cmd ()
 566   #+sb-thread
 567   (dolist (thread (all-threads))
 568     (format *output* "~&~A" thread)
 569     (when (eq thread sb-thread:*current-thread*)
 570       (format *output* " [current listener]")))
 571   #-sb-thread
 572   (format *output* "~&Threads are not supported in this version of sbcl")
 573   (values))
 574
 575 (defun sb-aclrepl::kill-cmd (&rest selected-threads)
 576   #+sb-thread
 577   (dolist (thread selected-threads)
 578     (let ((found (find thread (all-threads) :key 'sb-thread:thread-name
 579                        :test 'equal)))
 580       (if found
 581           (progn
 582             (format *output* "~&Destroying thread ~A" thread)
 583             (sb-thread:destroy-thread found))
 584           (format *output* "~&Thread ~A not found" thread))))
 585   #-sb-thread
 586   (declare (ignore selected-threads))
 587   #-sb-thread
 588   (format *output* "~&Threads are not supported in this version of sbcl")
 589   (values))
 590
 591 (defun focus-cmd (&optional process)
 592   #-sb-thread
 593   (declare (ignore process))
 594   #+sb-thread
 595   (when process
 596     (format *output* "~&Focusing on next thread waiting waiting for the debugger~%"))
 597   #+sb-thread
 598   (progn
 599     (sb-thread:release-foreground)
 600     (sleep 1))
 601   #-sb-thread
 602   (format *output* "~&Threads are not supported in this version of sbcl")
 603   (values))
 604
 605 (defun reset-cmd ()
 606   (throw 'sb-impl::toplevel-catcher nil))
 607
 608 (defun dirs-cmd ()
 609   (dolist (dir *dir-stack*)
 610     (format *output* "~a~%" dir))
 611   (values))
 612
 613 \f
 614 ;;;; dispatch table for commands
 615
 616 (let ((cmd-table
 617        '(("aliases" 3 alias-cmd "show aliases")
 618          ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
 619          ("bottom" 3 bottom-cmd "move to bottom stack frame")
 620          ("top" 3 top-cmd "move to top stack frame")
 621          ("bt" 2 bt-cmd "backtrace `n' stack frames, default all")
 622          ("up" 2 up-cmd "move up `n' stack frames, default 1")
 623          ("dn" 2 dn-cmd "move down `n' stack frames, default 1")
 624          ("cd" 2 cd-cmd "change default diretory" :parsing :string)
 625          ("ld" 2 ld-cmd "load a file" :parsing :string)
 626          ("cf" 2 cf-cmd "compile file" :parsing :string)
 627          ("cload" 2 cload-cmd "compile if needed and load file"
 628           :parsing :string)
 629          ("current" 3 current-cmd "print the expression for the current stack frame")
 630          ("continue" 4 continue-cmd "continue from a continuable error")
 631          ("describe" 2 describe-cmd "describe an object")
 632          ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
 633          ("package" 2 package-cmd "change current package")
 634          ("error" 3 error-cmd "print the last error message")
 635          ("exit" 2 exit-cmd "exit sbcl")
 636          ("frame" 2 frame-cmd "print info about the current frame")
 637          ("help" 2 help-cmd "print this help")
 638          ("history" 3 history-cmd "print the recent history")
 639          ("inspect" 2 inspect-cmd "inspect an object")
 640          ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
 641          #+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes")
 642          #+sb-thread ("focus" 2 focus-cmd "focus the top level on a process")
 643          ("local" 3 local-cmd "print the value of a local variable")
 644          ("pwd" 3 pwd-cmd "print current directory")
 645          ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
 646          ("pop" 3 pop-cmd "pop up `n' (default 1) break levels")
 647          ("popd" 4 popd-cmd "pop directory from stack")
 648          #+sb-thread ("processes" 3 processes-cmd "list all processes")
 649          ("reset" 3 reset-cmd "reset to top break level")
 650          ("trace" 2 trace-cmd "trace a function")
 651          ("untrace" 4 untrace-cmd "untrace a function")
 652          ("dirs" 2 dirs-cmd "show directory stack")
 653          ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string)
 654          ("zoom" 2 zoom-cmd "print the runtime stack")
 655          )))
 656   (dolist (cmd cmd-table)
 657     (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
 658       (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
 659 \f
 660 ;;;; machinery for aliases
 661
 662 (defsetf alias (name &key abbr-len description) (user-func)
 663   `(progn
 664     (%add-entry
 665      (make-cte (quote ,name) ,user-func ,description nil :alias ,abbr-len))
 666     (quote ,name)))
 667
 668 (defmacro alias (name-param args &rest body)
 669   (let ((parsing nil)
 670         (desc "")
 671         (abbr-index nil)
 672         (name (if (atom name-param)
 673                   name-param
 674                   (car name-param))))
 675     (when (consp name-param)
 676      (dolist (param (cdr name-param))
 677         (cond
 678           ((or
 679             (eq param :case-sensitive)
 680             (eq param :string))
 681            (setq parsing param))
 682           ((stringp param)
 683            (setq desc param))
 684           ((numberp param)
 685            (setq abbr-index param)))))
 686     `(progn
 687       (%add-entry
 688        (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index
 689                                                                                (1+ ,abbr-index)))
 690        ,abbr-index)
 691       ,name)))
 692
 693
 694 (defun remove-alias (&rest aliases)
 695   (declare (list aliases))
 696   (let ((keys '())
 697         (remove-all (not (null (find :all aliases)))))
 698     (unless remove-all  ;; ensure all alias are strings
 699       (setq aliases
 700             (loop for alias in aliases
 701                   collect
 702                   (etypecase alias
 703                     (string
 704                      alias)
 705                     (symbol
 706                      (symbol-name alias))))))
 707     (maphash
 708      (lambda (key cmd)
 709        (when (eq (cmd-table-entry-group cmd) :alias)
 710          (if remove-all
 711              (push key keys)
 712              (when (some
 713                     (lambda (alias)
 714                       (let ((klen (length key)))
 715                         (and (>= (length alias) klen)
 716                              (string-equal (subseq alias 0 klen)
 717                                            (subseq key 0 klen)))))
 718                     aliases)
 719                (push key keys)))))
 720      *cmd-table-hash*)
 721     (dolist (key keys)
 722       (remhash key *cmd-table-hash*))
 723     keys))
 724 \f
 725 ;;;; low-level reading/parsing functions
 726
 727 ;;; Skip white space (but not #\NEWLINE), and peek at the next
 728 ;;; character.
 729 (defun peek-char-non-whitespace (&optional stream)
 730   (do ((char (peek-char nil stream nil *eof-marker*)
 731              (peek-char nil stream nil *eof-marker*)))
 732       ((not (whitespace-char-not-newline-p char)) char)
 733     (read-char stream)))
 734
 735 (defun string-trim-whitespace (str)
 736   (string-trim '(#\space #\tab #\return)
 737                str))
 738
 739 (defun whitespace-char-p (x)
 740   (and (characterp x)
 741        (or (char= x #\space)
 742            (char= x #\tab)
 743            (char= x #\page)
 744            (char= x #\newline)
 745            (char= x #\return))))
 746
 747 (defun whitespace-char-not-newline-p (x)
 748   (and (whitespace-char-p x)
 749        (not (char= x #\newline))))
 750 \f
 751 ;;;; linking into SBCL hooks
 752
 753 (defun repl-prompt-fun (stream)
 754   (let ((break-level (when (plusp *break-level*)
 755                        *break-level*))
 756         (frame-number (when (and (plusp *break-level*)
 757                                  sb-debug::*current-frame*)
 758                         (sb-di::frame-number sb-debug::*current-frame*))))
 759     (sb-thread::get-foreground)
 760     (fresh-line stream)
 761     (if (functionp *prompt*)
 762         (write-string (funcall *prompt*
 763                                break-level
 764                                frame-number
 765                                *inspect-break*
 766                                *continuable-break*
 767                                (prompt-package-name) *cmd-number*)
 768                       stream)
 769         (handler-case
 770             (format nil *prompt*
 771                     break-level
 772                     frame-number
 773                     *inspect-break*
 774                     *continuable-break*
 775                     (prompt-package-name) *cmd-number*)
 776           (error ()
 777             (format stream "~&Prompt error>  "))
 778           (:no-error (prompt)
 779             (format stream "~A" prompt))))))
 780
 781 (defun process-cmd (user-cmd)
 782   ;; Processes a user command. Returns t if the user-cmd was a top-level
 783   ;; command
 784   (cond ((eq user-cmd *eof-cmd*)
 785          (when *exit-on-eof*
 786            (sb-ext:quit))
 787          (format *output* "EOF~%")
 788          t)
 789         ((eq user-cmd *null-cmd*)
 790          t)
 791         ((eq (user-cmd-func user-cmd) :cmd-error)
 792          (format *output* "Unknown top-level command: ~s.~%"
 793                  (user-cmd-input user-cmd))
 794          (format *output* "Type `~Ahelp' for the list of commands.~%" *command-char*)
 795          t)
 796         ((eq (user-cmd-func user-cmd) :history-error)
 797          (format *output* "Input numbered ~d is not on the history list~%"
 798                  (user-cmd-input user-cmd))
 799          t)
 800         ((functionp (user-cmd-func user-cmd))
 801          (add-to-history user-cmd)
 802          (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd))
 803          ;;(fresh-line)
 804          t)
 805         (t
 806          (add-to-history user-cmd)
 807          nil))) ; nope, not in my job description
 808
 809 (defun repl-read-form-fun (input output)
 810   ;; Pick off all the leading ACL magic commands, then return a normal
 811   ;; Lisp form.
 812   (let ((*input* input)
 813         (*output* output))
 814     (loop for user-cmd = (read-cmd *input*) do
 815         (if (process-cmd user-cmd)
 816             (progn
 817               (funcall sb-int:*repl-prompt-fun* *output*)
 818               (force-output *output*))
 819             (return (user-cmd-input user-cmd))))))
 820
 821
 822 (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
 823       sb-int:*repl-read-form-fun* #'repl-read-form-fun)
 824
 825 (defmacro with-new-repl-state ((&rest vars) &body forms)
 826   (let ((gvars (mapcar (lambda (var) (gensym (symbol-name var))) vars)))
 827     `(let (,@(mapcar (lambda (var gvar) `(,gvar ,var)) vars gvars))
 828       (lambda (noprint)
 829         (let ((*noprint* noprint))
 830           (let (,@(mapcar (lambda (var gvar) `(,var ,gvar)) vars gvars))
 831             (unwind-protect
 832                  (progn ,@forms)
 833               ,@(mapcar (lambda (var gvar) `(setf ,gvar ,var))
 834                         vars gvars))))))))
 835
 836 (defun make-repl-fun ()
 837   (with-new-repl-state (*break-level* *inspect-break* *continuable-break*
 838                         *dir-stack* *command-char* *prompt*
 839                         *use-short-package-name* *max-history* *exit-on-eof*
 840                         *history* *cmd-number*)
 841     (repl :noprint noprint :break-level 0)))
 842
 843 (when (boundp 'sb-impl::*repl-fun-generator*)
 844   (setq sb-impl::*repl-fun-generator* #'make-repl-fun))