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