contrib/sb-aclrepl/repl.lisp

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