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 (eval-when (:compile-toplevel :load-toplevel :execute)
  19   (defparameter *default-prompt* "~&~A(~d): "
  20     "The default prompt."))
  21 (defparameter *prompt* #.*default-prompt*
  22   "The current prompt string or formatter function.")
  23 (defparameter *use-short-package-name* t
  24   "when T, use the shortnest package nickname in a prompt")
  25 (defparameter *dir-stack* nil
  26   "The top-level directory stack")
  27 (defparameter *command-char* #\:
  28   "Prefix character for a top-level command")
  29 (defvar *max-history* 24
  30   "Maximum number of history commands to remember")
  31 (defvar *exit-on-eof* t
  32   "If T, then exit when the EOF character is entered.")
  33 (defparameter *history* nil
  34   "History list")
  35 (defparameter *cmd-number* 1
  36   "Number of the next command")
  37 (defparameter *repl-output* nil
  38   "The output stream for the repl")
  39 (defparameter *repl-input* nil
  40   "The input stream for the repl")
  41
  42 (declaim (type list *history*))
  43
  44 (defstruct user-cmd
  45   (input nil) ; input, maybe a string or form
  46   (func nil)  ; cmd func entered, overloaded
  47               ; (:eof :null-cmd :cmd-error :history-error)
  48   (args nil)  ; args for cmd func
  49   (hnum nil)) ; history number
  50
  51 (defvar *eof-marker* (cons :eof nil))
  52 (defvar *eof-cmd* (make-user-cmd :func :eof))
  53 (defvar *null-cmd* (make-user-cmd :func :null-cmd))
  54
  55 (defparameter *cmd-table-hash*
  56   (make-hash-table :size 30 :test #'equal))
  57
  58 ;; Set up binding for multithreading
  59
  60 (let ((*prompt* #.*default-prompt*)
  61       (*use-short-package-name* t)
  62       (*dir-stack* nil)
  63       (*command-char* #\:)
  64       (*max-history* 24)
  65       (*exit-on-eof* t)
  66       (*history* nil)
  67       (*cmd-number* 1)
  68       (*repl-output* nil)
  69       (*repl-input* nil)
  70       )
  71
  72 (defun prompt-package-name ()
  73   (if *use-short-package-name*
  74       (car (sort (append
  75                   (package-nicknames cl:*package*)
  76                   (list (package-name cl:*package*)))
  77                  (lambda (a b) (< (length a) (length b)))))
  78       (package-name cl:*package*)))
  79
  80 (defun read-cmd (input-stream)
  81   ;; Reads a command from the user and returns a user-cmd object
  82   (flet ((parse-args (parsing args-string)
  83            (case parsing
  84              (:string
  85               (if (zerop (length args-string))
  86                   nil
  87                   (list args-string)))
  88              (t
  89               (let ((string-stream (make-string-input-stream args-string)))
  90                 (loop as arg = (read string-stream nil *eof-marker*)
  91                       until (eq arg *eof-marker*)
  92                       collect arg))))))
  93     (let ((next-char (peek-char-non-whitespace input-stream)))
  94       (cond
  95         ((eql next-char *command-char*)
  96          (let* ((line (string-trim-whitespace (read-line input-stream)))
  97                 (first-space-pos (position #\space line))
  98                 (cmd-string (subseq line 1 first-space-pos))
  99                 (cmd-args-string
 100                  (if first-space-pos
 101                      (string-trim-whitespace (subseq line first-space-pos))
 102                      "")))
 103            (declare (string line))
 104            (if (numberp (read-from-string cmd-string))
 105                (let ((cmd (get-history (read-from-string cmd-string))))
 106                  (if (eq cmd *null-cmd*)
 107                      (make-user-cmd :func :history-error
 108                                     :input (read-from-string cmd-string))
 109                      (make-user-cmd :func (user-cmd-func cmd)
 110                                     :input (user-cmd-input cmd)
 111                                     :args (user-cmd-args cmd)
 112                                     :hnum *cmd-number*)))
 113                (let ((cmd-entry (find-cmd cmd-string)))
 114                  (if cmd-entry
 115                      (make-user-cmd :func (cmd-table-entry-func cmd-entry)
 116                                     :input line
 117                                     :args (parse-args
 118                                            (cmd-table-entry-parsing cmd-entry)
 119                                            cmd-args-string)
 120                                     :hnum *cmd-number*)
 121                      (make-user-cmd :func :cmd-error
 122                                     :input cmd-string)
 123                      )))))
 124         ((eql next-char #\newline)
 125          (read-char input-stream)
 126          *null-cmd*)
 127       (t
 128        (let ((form (read input-stream nil *eof-marker*)))
 129          (if (eq form *eof-marker*)
 130              *eof-cmd*
 131              (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
 132
 133 ;;; cmd table entry
 134 (defstruct cmd-table-entry
 135   (name nil) ; name of command
 136   (func nil) ; function handler
 137   (desc nil) ; short description
 138   (parsing nil) ; (:string :case-sensitive nil)
 139   (group nil)) ; command group (:cmd or :alias)
 140
 141 (defun make-cte (name-param func desc parsing group)
 142   (let ((name (etypecase name-param
 143                 (string
 144                  name-param)
 145                 (symbol
 146                  (string-downcase (write-to-string name-param))))))
 147     (make-cmd-table-entry :name name :func func :desc desc
 148                           :parsing parsing :group group)))
 149
 150 (defun %add-entry (cmd &optional abbr-len)
 151   (let* ((name (cmd-table-entry-name cmd))
 152          (alen (if abbr-len
 153                    abbr-len
 154                    (length name))))
 155     (dotimes (i (length name))
 156       (when (>= i (1- alen))
 157         (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)
 158               cmd)))))
 159
 160 (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)
 161   (%add-entry
 162    (make-cte cmd-string (symbol-function func-name) desc parsing :cmd)
 163    abbr-len))
 164
 165 (defun find-cmd (cmdstr)
 166   (gethash (string-downcase cmdstr) *cmd-table-hash*))
 167
 168 (defun user-cmd= (c1 c2)
 169   "Returns T if two user commands are equal"
 170   (and (eq (user-cmd-func c1) (user-cmd-func c2))
 171        (equal (user-cmd-args c1) (user-cmd-args c2))
 172        (equal (user-cmd-input c1) (user-cmd-input c2))))
 173
 174 (defun add-to-history (cmd)
 175   (unless (and *history* (user-cmd= cmd (car *history*)))
 176     (when (>= (length *history*) *max-history*)
 177       (setq *history* (nbutlast *history* (+ (length *history*) *max-history* 1))))
 178     (push cmd *history*)
 179     (incf *cmd-number*)))
 180
 181 (defun get-history (n)
 182   (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
 183     (if cmd
 184         cmd
 185         *null-cmd*)))
 186
 187 (defun get-cmd-doc-list (&optional (group :cmd))
 188   "Return list of all commands"
 189   (let ((cmds '()))
 190     (maphash (lambda (k v)
 191                (when (and
 192                       (eql (length k) (length (cmd-table-entry-name v)))
 193                       (eq (cmd-table-entry-group v) group))
 194                  (push (list k (cmd-table-entry-desc v)) cmds)))
 195              *cmd-table-hash*)
 196     (sort cmds #'string-lessp :key #'car)))
 197
 198 (defun cd-cmd (&optional string-dir)
 199   (cond
 200     ((or (zerop (length string-dir))
 201          (string= string-dir "~"))
 202      (setf cl:*default-pathname-defaults* (user-homedir-pathname)))
 203     (t
 204      (let ((new (truename string-dir)))
 205        (when (pathnamep new)
 206          (setf cl:*default-pathname-defaults* new)))))
 207   (format *repl-output* "~A~%" (namestring cl:*default-pathname-defaults*))
 208   (values))
 209
 210 (defun pwd-cmd ()
 211   (format *repl-output* "Lisp's current working directory is ~s.~%"
 212           (namestring cl:*default-pathname-defaults*))
 213   (values))
 214
 215 (defun trace-cmd (&rest args)
 216   (if args
 217       (format *repl-output* "~A~%" (eval (sb-debug::expand-trace args)))
 218       (format *repl-output* "~A~%" (sb-debug::%list-traced-funs)))
 219   (values))
 220
 221 (defun untrace-cmd (&rest args)
 222   (if args
 223       (format *repl-output* "~A~%"
 224               (eval
 225                (sb-int:collect ((res))
 226                 (let ((current args))
 227                   (loop
 228                    (unless current (return))
 229                    (let ((name (pop current)))
 230                      (res (if (eq name :function)
 231                               `(sb-debug::untrace-1 ,(pop current))
 232                               `(sb-debug::untrace-1 ',name))))))
 233                 `(progn ,@(res) t))))
 234       (format *repl-output* "~A~%" (eval (sb-debug::untrace-all))))
 235   (values))
 236
 237 (defun exit-cmd (&optional (status 0))
 238   #+sb-thread
 239   (let ((threads (sb-thread::mapcar-threads #'identity)))
 240     (if (> (length threads) 1)
 241         (progn
 242           (format *repl-output* "The following threads are running, can't quit~%")
 243           (format *repl-output* "~S~%" threads))
 244         (quit :unix-status status)))
 245   #-sb-thread
 246   (quit :unix-status status)
 247   (values))
 248
 249 (defun package-cmd (&optional pkg)
 250   (cond
 251     ((null pkg)
 252      (format *repl-output* "The ~A package is current.~%"
 253              (package-name cl:*package*)))
 254     ((null (find-package (write-to-string pkg)))
 255      (format *repl-output* "Unknown package: ~A.~%" pkg))
 256     (t
 257      (setf cl:*package* (find-package (write-to-string pkg)))))
 258   (values))
 259
 260 (defun string-to-list-skip-spaces (str)
 261   "Return a list of strings, delimited by spaces, skipping spaces."
 262   (when str
 263     (loop for i = 0 then (1+ j)
 264           as j = (position #\space str :start i)
 265           when (not (char= (char str i) #\space))
 266           collect (subseq str i j) while j)))
 267
 268 (let ((last-files-loaded nil))
 269   (defun ld-cmd (&optional string-files)
 270     (if string-files
 271         (setq last-files-loaded string-files)
 272         (setq string-files last-files-loaded))
 273     (dolist (arg (string-to-list-skip-spaces string-files))
 274       (format *repl-output* "loading ~a~%" arg)
 275       (load arg)))
 276   (values))
 277
 278 (defun cf-cmd (string-files)
 279   (when string-files
 280     (dolist (arg (string-to-list-skip-spaces string-files))
 281       (compile-file arg)))
 282   (values))
 283
 284 (defun >-num (x y)
 285   "Return if x and y are numbers, and x > y"
 286   (and (numberp x) (numberp y) (> x y)))
 287
 288 (defun newer-file-p (file1 file2)
 289   "Is file1 newer (written later than) file2?"
 290   (>-num (if (probe-file file1) (file-write-date file1))
 291          (if (probe-file file2) (file-write-date file2))))
 292
 293 (defun compile-file-as-needed (src-path)
 294   "Compiles a file if needed, returns path."
 295   (let ((dest-path (compile-file-pathname src-path)))
 296     (when (or (not (probe-file dest-path))
 297               (newer-file-p src-path dest-path))
 298       (ensure-directories-exist dest-path)
 299       (compile-file src-path :output-file dest-path))
 300     dest-path))
 301 \f
 302 ;;;; implementation of commands
 303
 304 (defun apropos-cmd (string)
 305   (apropos (string-upcase string))
 306   (values))
 307
 308 (let ((last-files-loaded nil))
 309   (defun cload-cmd (&optional string-files)
 310     (if string-files
 311         (setq last-files-loaded string-files)
 312         (setq string-files last-files-loaded))
 313     (dolist (arg (string-to-list-skip-spaces string-files))
 314       (format *repl-output* "loading ~a~%" arg)
 315       (load (compile-file-as-needed arg)))
 316     (values)))
 317
 318 (defun inspect-cmd (arg)
 319   (inspector arg nil *repl-output*)
 320   (values))
 321
 322 (defun istep-cmd (&optional arg-string)
 323   (istep arg-string *repl-output*)
 324   (values))
 325
 326 (defun describe-cmd (&rest args)
 327   (dolist (arg args)
 328     (eval `(describe ,arg)))
 329   (values))
 330
 331 (defun macroexpand-cmd (arg)
 332   (pprint (macroexpand arg) *repl-output*)
 333   (values))
 334
 335 (defun history-cmd ()
 336   (let ((n (length *history*)))
 337     (declare (fixnum n))
 338     (dotimes (i n)
 339       (declare (fixnum i))
 340       (let ((hist (nth (- n i 1) *history*)))
 341         (format *repl-output* "~3A ~A~%" (user-cmd-hnum hist)
 342                 (user-cmd-input hist)))))
 343   (values))
 344
 345 (defun help-cmd (&optional cmd)
 346   (cond
 347     (cmd
 348      (let ((cmd-entry (find-cmd cmd)))
 349        (if cmd-entry
 350            (format *repl-output* "Documentation for ~A: ~A~%"
 351                    (cmd-table-entry-name cmd-entry)
 352                    (cmd-table-entry-desc cmd-entry)))))
 353     (t
 354      (format *repl-output* "~13A ~a~%" "Command" "Description")
 355      (format *repl-output* "------------- -------------~%")
 356      (format *repl-output* "~13A ~A~%" "n"
 357              "(for any number n) recall nth command from history list")
 358      (dolist (doc-entry (get-cmd-doc-list :cmd))
 359        (format *repl-output* "~13A ~A~%" (car doc-entry) (cadr doc-entry)))))
 360   (values))
 361
 362 (defun alias-cmd ()
 363   (let ((doc-entries (get-cmd-doc-list :alias)))
 364     (typecase doc-entries
 365       (cons
 366        (format *repl-output* "~13A ~a~%" "Alias" "Description")
 367        (format *repl-output* "------------- -------------~%")
 368        (dolist (doc-entry doc-entries)
 369          (format *repl-output* "~13A ~A~%" (car doc-entry) (cadr doc-entry))))
 370       (t
 371        (format *repl-output* "No aliases are defined~%"))))
 372   (values))
 373
 374 (defun shell-cmd (string-arg)
 375   (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
 376                       :input nil :output *repl-output*)
 377   (values))
 378
 379 (defun pushd-cmd (string-arg)
 380   (push string-arg *dir-stack*)
 381   (cd-cmd *repl-output* string-arg)
 382   (values))
 383
 384 (defun popd-cmd ()
 385   (if *dir-stack*
 386       (let ((dir (pop *dir-stack*)))
 387         (cd-cmd dir))
 388       (format *repl-output* "No directory on stack to pop.~%"))
 389   (values))
 390
 391 (defun dirs-cmd ()
 392   (dolist (dir *dir-stack*)
 393     (format *repl-output* "~a~%" dir))
 394   (values))
 395
 396 \f
 397 ;;;; dispatch table for commands
 398
 399 (let ((cmd-table
 400        '(("aliases" 3 alias-cmd "show aliases")
 401          ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
 402          ("cd" 2 cd-cmd "change default diretory" :parsing :string)
 403          ("ld" 2 ld-cmd "load a file" :parsing :string)
 404          ("cf" 2 cf-cmd "compile file" :parsing :string)
 405          ("cload" 2 cload-cmd "compile if needed and load file"
 406           :parsing :string)
 407          ("describe" 2 describe-cmd "describe an object")
 408          ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
 409          ("package" 2 package-cmd "change current package")
 410          ("exit" 2 exit-cmd "exit sbcl")
 411          ("help" 2 help-cmd "print this help")
 412          ("history" 3 history-cmd "print the recent history")
 413          ("inspect" 2 inspect-cmd "inspect an object")
 414          ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
 415          ("pwd" 3 pwd-cmd "print current directory")
 416          ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
 417          ("popd" 2 popd-cmd "pop directory from stack")
 418          ("trace" 2 trace-cmd "trace a function")
 419          ("untrace" 4 untrace-cmd "untrace a function")
 420          ("dirs" 2 dirs-cmd "show directory stack")
 421          ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string))))
 422   (dolist (cmd cmd-table)
 423     (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
 424       (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
 425 \f
 426 ;;;; machinery for aliases
 427
 428 (defsetf alias (name) (user-func)
 429   `(progn
 430     (%add-entry
 431      (make-cte (quote ,name) ,user-func "" nil :alias))
 432     (quote ,name)))
 433
 434 (defmacro alias (name-param args &rest body)
 435   (let ((parsing nil)
 436         (desc "")
 437         (abbr-index nil)
 438         (name (if (atom name-param)
 439                   name-param
 440                   (car name-param))))
 441     (when (consp name-param)
 442      (dolist (param (cdr name-param))
 443         (cond
 444           ((or
 445             (eq param :case-sensitive)
 446             (eq param :string))
 447            (setq parsing param))
 448           ((stringp param)
 449            (setq desc param))
 450           ((numberp param)
 451            (setq abbr-index param)))))
 452     `(progn
 453       (%add-entry
 454        (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias)
 455        ,abbr-index)
 456       ,name)))
 457
 458
 459 (defun remove-alias (&rest aliases)
 460   (declare (list aliases))
 461   (let ((keys '())
 462         (remove-all (not (null (find :all aliases)))))
 463     (unless remove-all  ;; ensure all alias are strings
 464       (setq aliases
 465             (loop for alias in aliases
 466                   collect
 467                   (etypecase alias
 468                     (string
 469                      alias)
 470                     (symbol
 471                      (symbol-name alias))))))
 472     (maphash
 473      (lambda (key cmd)
 474        (when (eq (cmd-table-entry-group cmd) :alias)
 475          (if remove-all
 476              (push key keys)
 477              (when (some
 478                     (lambda (alias)
 479                       (let ((klen (length key)))
 480                         (and (>= (length alias) klen)
 481                              (string-equal (subseq alias 0 klen)
 482                                            (subseq key 0 klen)))))
 483                     aliases)
 484                (push key keys)))))
 485      *cmd-table-hash*)
 486     (dolist (key keys)
 487       (remhash key *cmd-table-hash*))
 488     keys))
 489 \f
 490 ;;;; low-level reading/parsing functions
 491
 492 ;;; Skip white space (but not #\NEWLINE), and peek at the next
 493 ;;; character.
 494 (defun peek-char-non-whitespace (&optional stream)
 495   (do ((char (peek-char nil stream nil *eof-marker*)
 496              (peek-char nil stream nil *eof-marker*)))
 497       ((not (whitespace-char-not-newline-p char)) char)
 498     (read-char stream)))
 499
 500 (defun string-trim-whitespace (str)
 501   (string-trim '(#\space #\tab #\return)
 502                str))
 503
 504 (defun whitespace-char-not-newline-p (x)
 505   (and (characterp x)
 506        (or (char= x #\space)
 507            (char= x #\tab)
 508            (char= x #\return))))
 509
 510 \f
 511 ;;;; linking into SBCL hooks
 512
 513 (defun repl-prompt-fun (stream)
 514   (if (functionp *prompt*)
 515       (write-string (funcall *prompt* (prompt-package-name) *cmd-number*)
 516                     stream)
 517       (format stream *prompt* (prompt-package-name) *cmd-number*)))
 518
 519 (defun process-cmd (user-cmd input-stream output-stream)
 520   ;; Processes a user command. Returns t if the user-cmd was a top-level
 521   ;; command
 522   (cond ((eq user-cmd *eof-cmd*)
 523          (when *exit-on-eof*
 524            (quit))
 525          (format output-stream "EOF~%")
 526          t)
 527         ((eq user-cmd *null-cmd*)
 528          t)
 529         ((eq (user-cmd-func user-cmd) :cmd-error)
 530          (format output-stream "Unknown top-level command: ~s.~%"
 531                  (user-cmd-input user-cmd))
 532          (format output-stream "Type `:help' for the list of commands.~%")
 533          t)
 534         ((eq (user-cmd-func user-cmd) :history-error)
 535          (format output-stream "Input numbered ~d is not on the history list~%"
 536                  (user-cmd-input user-cmd))
 537          t)
 538         ((functionp (user-cmd-func user-cmd))
 539          (add-to-history user-cmd)
 540          (let ((*repl-output* output-stream)
 541                (*repl-input* input-stream))
 542            (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd)))
 543          (fresh-line)
 544          t)
 545         (t
 546          (add-to-history user-cmd)
 547          nil))) ; nope, not in my job description
 548
 549 (defun repl-read-form-fun (input-stream output-stream)
 550   ;; Pick off all the leading ACL magic commands, then return a normal
 551   ;; Lisp form.
 552   (loop for user-cmd = (read-cmd input-stream) do
 553         (if (process-cmd user-cmd input-stream output-stream)
 554             (progn
 555               (repl-prompt-fun output-stream)
 556               (force-output output-stream))
 557             (return (user-cmd-input user-cmd)))))
 558
 559
 560 (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
 561       sb-int:*repl-read-form-fun* #'repl-read-form-fun)
 562
 563 ) ;; close special variables bindings
 564