;;;; Replicate much of the ACL toplevel functionality in SBCL. Mostly ;;;; this is portable code, but fundamentally it all hangs from a few ;;;; SBCL-specific hooks like SB-INT:*REPL-READ-FUN* and ;;;; SB-INT:*REPL-PROMPT-FUN*. ;;;; ;;;; The documentation, which may or may not apply in its entirety at ;;;; any given time, for this functionality is on the ACL website: ;;;;   <http://www.franz.com/support/documentation/6.2/doc/top-level.htm>. (cl:in-package :sb-aclrepl) (defstruct user-cmd   (input nil) ; input, maybe a string or form  (func nil)  ; cmd func entered, overloaded              ; (:eof :null-cmd :cmd-error :history-error)  (args nil)  ; args for cmd func  (hnum nil)) ; history number ;;; cmd table entry (defstruct cmd-table-entry   (name nil) ; name of command  (func nil) ; function handler  (desc nil) ; short description  (parsing nil) ; (:string :case-sensitive nil)  (group nil) ; command group (:cmd or :alias)  (abbr-len 0)) ; abbreviation length (eval-when (:compile-toplevel :load-toplevel :execute)   (defparameter *default-prompt*     "~:[~3*~;[~:*~D~:[~;~:*:~D~]~:[~;i~]~:[~;c~]] ~]~A(~D): "     "The default prompt.")) (defparameter *prompt* #.*default-prompt*   "The current prompt string or formatter function.") (defparameter *use-short-package-name* t   "when T, use the shortnest package nickname in a prompt") (defparameter *dir-stack* nil   "The top-level directory stack") (defparameter *command-char* #\:   "Prefix character for a top-level command") (defvar *max-history* 100   "Maximum number of history commands to remember") (defvar *exit-on-eof* t   "If T, then exit when the EOF character is entered.") (defparameter *history* nil   "History list") (defparameter *cmd-number* 1   "Number of the next command") (defvar *input*) (defvar *output*) (declaim (type list *history*)) (defvar *eof-marker* :eof) (defvar *eof-cmd* (make-user-cmd :func :eof)) (defvar *null-cmd* (make-user-cmd :func :null-cmd)) (defparameter *cmd-table-hash*   (make-hash-table :size 30 :test #'equal)) (defun prompt-package-name ()   (if *use-short-package-name*       (car (sort (append                   (package-nicknames cl:*package*)                   (list (package-name cl:*package*)))                  (lambda (a b) (< (length a) (length b)))))       (package-name cl:*package*))) (defun read-cmd (input-stream)   ;; Reads a command from the user and returns a user-cmd object  (let* ((next-char (peek-char-non-whitespace input-stream))          (cmd (cond                 ((eql *command-char* next-char)                  (dispatch-command-line input-stream))                 ((eql #\newline next-char)                  (read-char input-stream)                  *null-cmd*)                 ((eql :eof next-char)                  *eof-cmd*)                 (t                  (let* ((eof (cons nil *eof-marker*))                         (form (read input-stream nil eof)))                    (if (eq form eof)                        *eof-cmd*                        (make-user-cmd :input form :func nil :hnum *cmd-number*)))))))     (if (and (eq cmd *eof-cmd*) (typep input-stream 'string-stream))         (throw 'repl-catcher cmd)         cmd))) (defun dispatch-command-line (input-stream)   "Processes an input line that starts with *command-char*"   (let* ((line (string-trim-whitespace (read-line input-stream)))          (first-space-pos (position #\space line))          (cmd-string (subseq line 1 first-space-pos))          (cmd-args-string           (if first-space-pos               (string-trim-whitespace (subseq line first-space-pos))               "")))     (declare (simple-string line))     (cond       ((or (zerop (length cmd-string))            (whitespace-char-p (char cmd-string 0)))        *null-cmd*)       ((or (numberp (read-from-string cmd-string))            (char= (char cmd-string 0) #\+)            (char= (char cmd-string 0) #\-))        (process-cmd-numeric cmd-string cmd-args-string))       ((char= (char cmd-string 0) *command-char*)        (process-history-search (subseq cmd-string 1) cmd-args-string))       (t        (process-cmd-text cmd-string line cmd-args-string))))) (defun process-cmd-numeric (cmd-string cmd-args-string)   "Process a numeric cmd, such as ':123'"   (let* ((first-char (char cmd-string 0))          (number-string (if (digit-char-p first-char)                             cmd-string                             (subseq cmd-string 1)))          (is-minus (char= first-char #\-))          (raw-number (read-from-string number-string))          (number (if is-minus                      (- *cmd-number* raw-number)                      raw-number))          (cmd (get-history number)))     (when (eq cmd *null-cmd*)       (return-from process-cmd-numeric         (make-user-cmd :func :history-error :input (read-from-string                                                     cmd-string))))     (maybe-return-history-cmd cmd cmd-args-string))) (defun maybe-return-history-cmd (cmd cmd-args-string)   (format *output* "~A~%" (user-cmd-input cmd))   (let ((dont-redo          (when (and (stringp cmd-args-string)                     (plusp (length cmd-args-string))                     (char= #\? (char cmd-args-string 0)))            (do ((line nil (read-line *input*)))                ((and line (or (zerop (length line))                               (string-equal line "Y")                               (string-equal line "N")))                 (when (string-equal line "N")                   t))              (when line                (format *output* "Type \"y\" for yes or \"n\" for no.~%"))              (format *output* "redo? [y] ")              (force-output *output*)))))     (if dont-redo         *null-cmd*         (make-user-cmd :func (user-cmd-func cmd)                        :input (user-cmd-input cmd)                        :args (user-cmd-args cmd)                        :hnum *cmd-number*)))) (defun find-history-matching-pattern (cmd-string)   "Return history item matching cmd-string or NIL if not found"   (dolist (his *history* nil)     (let* ((input (user-cmd-input his))            (string-input (if (stringp input)                              input                              (write-to-string input))))       (when (search cmd-string string-input :test #'string-equal)         (return-from find-history-matching-pattern his))))) (defun process-history-search (pattern cmd-args-string)   (let ((cmd (find-history-matching-pattern pattern)))     (unless cmd       (format *output* "No match on history list with pattern ~S~%" pattern)       (return-from process-history-search *null-cmd*))     (maybe-return-history-cmd cmd cmd-args-string))) (defun process-cmd-text (cmd-string line cmd-args-string)   "Process a text cmd, such as ':ld a b c'"   (flet ((parse-args (parsing args-string)            (case parsing              (:string               (if (zerop (length args-string))                   nil                   (list args-string)))              (t               (let ((string-stream (make-string-input-stream args-string))                     (eof (cons nil *eof-marker*))) ;new cons for eq uniqueness                (loop as arg = (read string-stream nil eof)                       until (eq arg eof)                       collect arg))))))     (let ((cmd-entry (find-cmd cmd-string)))       (unless cmd-entry         (return-from process-cmd-text           (make-user-cmd :func :cmd-error :input cmd-string)))       (make-user-cmd :func (cmd-table-entry-func cmd-entry)                      :input line                      :args (parse-args (cmd-table-entry-parsing cmd-entry)                                        cmd-args-string)                      :hnum *cmd-number*)))) (defun make-cte (name-param func desc parsing group abbr-len)   (let ((name (etypecase name-param                 (string                  name-param)                 (symbol                  (string-downcase (write-to-string name-param))))))     (make-cmd-table-entry :name name :func func :desc desc                           :parsing parsing :group group                           :abbr-len (if abbr-len                                         abbr-len                                         (length name))))) (defun %add-entry (cmd &optional abbr-len)   (let* ((name (cmd-table-entry-name cmd))          (alen (if abbr-len                    abbr-len                    (length name))))     (dotimes (i (length name))       (when (>= i (1- alen))         (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*)               cmd))))) (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing)   (%add-entry    (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len)    abbr-len)) (defun find-cmd (cmdstr)   (gethash (string-downcase cmdstr) *cmd-table-hash*)) (defun user-cmd= (c1 c2)   "Returns T if two user commands are equal"   (and (eq (user-cmd-func c1) (user-cmd-func c2))        (equal (user-cmd-args c1) (user-cmd-args c2))        (equal (user-cmd-input c1) (user-cmd-input c2)))) (defun add-to-history (cmd)   (unless (and *history* (user-cmd= cmd (car *history*)))     (when (>= (length *history*) *max-history*)       (setq *history* (nbutlast *history*                                 (1+ (- (length *history*) *max-history*)))))     (push cmd *history*)     (incf *cmd-number*))) (defun get-history (n)   (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))     (if cmd         cmd         *null-cmd*))) (defun get-cmd-doc-list (&optional (group :cmd))   "Return list of all commands"   (let ((cmds '()))     (maphash (lambda (k v)                (when (and                       (= (length k) (length (cmd-table-entry-name v)))                       (eq (cmd-table-entry-group v) group))                  (push (list k                              (if (= (cmd-table-entry-abbr-len v)                                     (length k))                                   ""                                   (subseq k 0 (cmd-table-entry-abbr-len v)))                              (cmd-table-entry-desc v)) cmds)))              *cmd-table-hash*)     (sort cmds #'string-lessp :key #'car))) (defun cd-cmd (&optional string-dir)   (cond     ((or (zerop (length string-dir))          (string= string-dir "~"))      (setf cl:*default-pathname-defaults* (user-homedir-pathname)))     (t      (let ((new (truename string-dir)))        (when (pathnamep new)          (setf cl:*default-pathname-defaults* new)))))   (format *output* "~A~%" (namestring cl:*default-pathname-defaults*))   (values)) (defun pwd-cmd ()   (format *output* "Lisp's current working directory is ~s.~%"           (namestring cl:*default-pathname-defaults*))   (values)) (defun trace-cmd (&rest args)   (if args       (format *output* "~A~%" (eval (sb-debug::expand-trace args)))       (format *output* "~A~%" (sb-debug::%list-traced-funs)))   (values)) (defun untrace-cmd (&rest args)   (if args       (format *output* "~A~%"               (eval                (sb-int:collect ((res))                 (let ((current args))                   (loop                    (unless current (return))                    (let ((name (pop current)))                      (res (if (eq name :function)                               `(sb-debug::untrace-1 ,(pop current))                               `(sb-debug::untrace-1 ',name))))))                 `(progn ,@(res) t))))       (format *output* "~A~%" (eval (sb-debug::untrace-all))))   (values)) #+sb-thread (defun all-threads ()   "Return a list of all threads"   (sb-thread:list-all-threads)) #+sb-thread (defun other-threads ()   "Returns a list of all threads except the current one"   (delete sb-thread:*current-thread* (all-threads))) (defun exit-cmd (&optional (status 0))   #+sb-thread   (let ((other-threads (other-threads)))     (when other-threads       (format *output* "There exists the following processes~%")       (format *output* "~{~A~%~}" other-threads)       (format *output* "Do you want to exit lisp anyway [n]? ")       (force-output *output*)       (let ((input (string-trim-whitespace (read-line *input*))))         (if (and (plusp (length input))                  (or (char= #\y (char input 0))                      (char= #\Y (char input 0))))             ;; loop in case more threads get created while trying to exit            (do ((threads other-threads (other-threads)))                 ((eq nil threads))               (map nil #'sb-thread:destroy-thread threads)               (sleep 0.2))             (return-from exit-cmd)))))   (sb-ext:quit :unix-status status)   (values)) (defun package-cmd (&optional pkg)   (cond     ((null pkg)      (format *output* "The ~A package is current.~%"              (package-name cl:*package*)))     ((null (find-package (write-to-string pkg)))      (format *output* "Unknown package: ~A.~%" pkg))     (t      (setf cl:*package* (find-package (write-to-string pkg)))))   (values)) (defun string-to-list-skip-spaces (str)   "Return a list of strings, delimited by spaces, skipping spaces."   (declare (type (or null string) str))   (when str     (loop for i = 0 then (1+ j)           as j = (position #\space str :start i)           when (not (char= (char str i) #\space))           collect (subseq str i j) while j))) (let ((last-files-loaded nil))   (defun ld-cmd (&optional string-files)     (if string-files         (setq last-files-loaded string-files)         (setq string-files last-files-loaded))     (dolist (arg (string-to-list-skip-spaces string-files))       (let ((file              (if (string= arg "~/" :end1 1 :end2 1)                  (merge-pathnames (parse-namestring                                    (string-left-trim "~/" arg))                                   (user-homedir-pathname))                  arg)))         (format *output* "loading ~S~%" file)         (load file))))   (values)) (defun cf-cmd (string-files)   (when string-files     (dolist (arg (string-to-list-skip-spaces string-files))       (compile-file arg)))   (values)) (defun >-num (x y)   "Return if x and y are numbers, and x > y"   (and (numberp x) (numberp y) (> x y))) (defun newer-file-p (file1 file2)   "Is file1 newer (written later than) file2?"   (>-num (if (probe-file file1) (file-write-date file1))          (if (probe-file file2) (file-write-date file2)))) (defun compile-file-as-needed (src-path)   "Compiles a file if needed, returns path."   (let ((dest-path (compile-file-pathname src-path)))     (when (or (not (probe-file dest-path))               (newer-file-p src-path dest-path))       (ensure-directories-exist dest-path)       (compile-file src-path :output-file dest-path))     dest-path))  ;;;; implementation of commands (defun apropos-cmd (string)   (apropos (string-upcase string))   (fresh-line *output*)   (values)) (let ((last-files-loaded nil))   (defun cload-cmd (&optional string-files)     (if string-files         (setq last-files-loaded string-files)         (setq string-files last-files-loaded))     (dolist (arg (string-to-list-skip-spaces string-files))       (format *output* "loading ~a~%" arg)       (load (compile-file-as-needed arg)))     (values))) (defun inspect-cmd (arg)   (inspector-fun (eval arg) nil *output*)   (values)) (defun istep-cmd (&optional arg-string)   (istep (string-to-list-skip-spaces arg-string) *output*)   (values)) (defun describe-cmd (&rest args)   (dolist (arg args)     (eval `(describe ,arg)))   (values)) (defun macroexpand-cmd (arg)   (pprint (macroexpand arg) *output*)   (values)) (defun history-cmd ()   (let ((n (length *history*)))     (declare (fixnum n))     (dotimes (i n)       (declare (fixnum i))       (let ((hist (nth (- n i 1) *history*)))         (format *output* "~3A " (user-cmd-hnum hist))         (if (stringp (user-cmd-input hist))             (format *output* "~A~%" (user-cmd-input hist))             (format *output* "~W~%" (user-cmd-input hist))))))   (values)) (defun help-cmd (&optional cmd)   (cond     (cmd      (let ((cmd-entry (find-cmd cmd)))        (if cmd-entry            (format *output* "Documentation for ~A: ~A~%"                    (cmd-table-entry-name cmd-entry)                    (cmd-table-entry-desc cmd-entry)))))     (t      (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION")      (format *output* "~11A ~4A ~A~%" "<n>" ""              "re-execute <n>th history command")      (dolist (doc-entry (get-cmd-doc-list :cmd))        (format *output* "~11A ~4A ~A~%" (first doc-entry)                (second doc-entry) (third doc-entry)))))   (values)) (defun alias-cmd ()   (let ((doc-entries (get-cmd-doc-list :alias)))     (typecase doc-entries       (cons        (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION")        (dolist (doc-entry doc-entries)          (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry))))       (t        (format *output* "No aliases are defined~%"))))   (values)) (defun shell-cmd (string-arg)   (sb-ext:run-program "/bin/sh" (list "-c" string-arg)                       :input nil :output *output*)   (values)) (defun pushd-cmd (string-arg)   (push string-arg *dir-stack*)   (cd-cmd string-arg)   (values)) (defun popd-cmd ()   (if *dir-stack*       (let ((dir (pop *dir-stack*)))         (cd-cmd dir))       (format *output* "No directory on stack to pop.~%"))   (values)) (defun pop-cmd (&optional (n 1))   (cond     (*inspect-break*      (throw</