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