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