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