MODULE=sb-aclrepl
-include ../vanilla-module.mk
-
-test::
- true
+include ../asdf-module.mk
--- /dev/null
+The sb-aclrepl module offers an AllegroCL style Read-Eval-Print Loop for
+SBCL. An AllegroCL style inspector is integrated. Adding an AllegroCL style
+debugger is planned.
+
+Questions, comments, or bug reports should be sent to Kevin Rosenberg
+<kevin@rosenbrg.net>.
--- /dev/null
+;;;; Inspector for sb-aclrepl
+;;;;
+;;;; 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/inspector.htm>.
+;;;;
+;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
+;;;; variable.
+
+(cl:in-package :sb-aclrepl)
+
+(defparameter *inspect-stack* nil
+ "Stack of the hierarchy of an inspected object.")
+
+(defparameter *parent-select-stack* nil
+ "a stack of the indices of parent object components that brought us to the current object.")
+
+(defparameter *inspect-length* 10
+ "Number of components to display.")
+
+;; FIXME - raw mode isn't currently used in object display
+(defparameter *inspect-raw* nil
+ "Raw mode for object display.")
+
+(defvar *inspected*)
+(setf (documentation '*inspected* 'variable)
+ "the value currently being inspected by CL:INSPECT")
+
+(defvar *inspect-help*
+":istep takes between 0 to 3 arguments.
+The commands are:
+:i redisplay current object
+:i = redisplay current object
+:i nil redisplay current object
+:i ? display this help
+:i * inspect the current * value
+:i + <form> inspect the (eval form)
+:i <index> inspect the numbered component of object
+:i <name> inspect the named component of object
+:i <form> evaluation and inspect form
+:i - inspect parent
+:i ^ inspect parent
+:i < inspect previous parent component
+:i > inspect next parent component
+:i set <index> <form> set indexed component to evalated form
+:i set <name> <form> set named component to evalated form
+:i print <max> set the maximum number of components to print
+:i skip <n> skip a number of components when printing
+:i tree print inspect stack
+")
+
+;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
+;;; indicates that that a slot is unbound.
+(defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))
+
+
+;; Setup binding for multithreading
+(let ((*inspect-stack* nil)
+ (*parent-select-stack* nil)
+ (*inspect-length* 10)
+ (*inspect-raw* nil)
+ (*inspected* nil))
+
+(defun inspector (object input-stream output-stream)
+ (declare (ignore input-stream))
+ (setq object (eval object))
+ (reset-stack)
+ (setq *inspect-stack* (list object))
+ (setq *parent-select-stack* (list "(inspect ...)"))
+ (%inspect output-stream))
+
+
+
+(defun istep (arg-string output-stream)
+ (%istep arg-string (string-to-list-skip-spaces arg-string) output-stream))
+
+(setq sb-impl::*inspect-fun* #'inspector)
+
+(defun reset-stack ()
+ (setq *inspect-stack* nil)
+ (setq *parent-select-stack* nil)
+ (makunbound '*inspected*))
+
+(defun %istep (arg-string args output-stream)
+ (let* ((option (car args))
+ (option-read (when arg-string
+ (read-from-string arg-string))))
+ (cond
+ ;; Redisplay
+ ((or (string= "=" option)
+ (zerop (length args)))
+ (%inspect output-stream))
+ ;; Select parent
+ ((or (string= "-" option)
+ (string= "^" option))
+ (cond
+ ((> (length *inspect-stack*) 1)
+ (pop *inspect-stack*)
+ (%inspect output-stream))
+ (*inspect-stack*
+ (format output-stream "Object has no parent.~%"))
+ (t
+ (%inspect output-stream))))
+ ;; Select * to inspect
+ ((string= "*" option)
+ (reset-stack)
+ (setq *inspect-stack* (list *))
+ (setq *parent-select-stack* (list "(inspect ...)"))
+ (%inspect output-stream))
+ ;; Start new inspect level for eval'd form
+ ((string= "+" option)
+ (inspector (eval (second args)) nil output-stream))
+ ;; Next or previous parent component
+ ((or (string= "<" option)
+ (string= ">" option))
+ (if *inspect-stack*
+ (if (eq (length *inspect-stack*) 1)
+ (format output-stream "Object does not have a parent")
+ (let ((parent (second *inspect-stack*))
+ (id (car *parent-select-stack*)))
+ (multiple-value-bind (position list-type elements)
+ (find-object-component parent id)
+ (declare (list elements)
+ (ignore list-type))
+ (let ((new-position (if (string= ">" option)
+ (1+ position)
+ (1- position))))
+ (if (< -1 new-position (length elements))
+ (let ((new-object (elt elements new-position)))
+ (setf (car *inspect-stack*) new-object)
+ (setf (car *parent-select-stack*)
+ (if (integerp id)
+ new-position
+ (read-from-string
+ (car (nth new-position elements)))))
+ (%inspect output-stream))
+ (format output-stream "Parent has no selectable component indexed by ~d"
+ new-position))))))
+ (%inspect output-stream)))
+ ;; Set component to eval'd form
+ ((string-equal "set" option)
+ (if *inspect-stack*
+ (let ((id (when (second args)
+ (read-from-string (second args)))))
+ (multiple-value-bind (position list-type elements)
+ (find-object-component (car *inspect-stack*) id)
+ (declare (ignore list-type))
+ (if elements
+ (if position
+ (let ((value-stirng (third args)))
+ (when value-stirng
+ (let ((new-value (eval (read-from-string (third args)))))
+ ;; FIXME -- this will require new new generic
+ ;; function to set component of the object
+ (format output-stream "Set component - not yet implemented")))
+ (%inspect output-stream))
+ (format output-stream
+ "Object has no selectable component named by ~A" id))
+ (format output-stream
+ "Object has no selectable components"))))
+ (%inspect output-stream)))
+ ;; Set/reset raw display mode for components
+ ((string-equal "raw" option)
+ (when *inspect-stack*
+ (when (and (second args)
+ (or (null (second args))
+ (eq (read-from-string (second args)) t)))
+ (setq *inspect-raw* t))
+ (%inspect output-stream)))
+ ;; Reset stack
+ ((string-equal "q" option)
+ (reset-stack))
+ ;; Display help
+ ((string-equal "?" option)
+ (format output-stream *inspect-help*))
+ ;; Set number of components to skip
+ ((string-equal "skip" option)
+ (let ((len (read-from-string (second args))))
+ (if (and (integerp len) (>= len 0))
+ (%inspect output-stream len)
+ (format output-stream "Skip missing or invalid~%"))))
+ ;; Print stack tree
+ ((string-equal "tree" option)
+ (if *inspect-stack*
+ (progn
+ (format output-stream "The current object is:~%")
+ (dotimes (i (length *inspect-stack*))
+ (format output-stream "~A, ~A~%"
+ (inspected-parts (nth i *inspect-stack*) :description t)
+ (let ((select (nth i *parent-select-stack*)))
+ (typecase select
+ (integer
+ (format nil "which is componenent number ~d of" select))
+ (symbol
+ (format nil "which is the ~a component of" select))
+ (string
+ (format nil "which was selected by ~S" select))
+ (t
+ (write-to-string select)))))))
+ (%inspect output-stream)))
+ ;; Set maximum number of components to print
+ ((string-equal "print" option)
+ (let ((len (read-from-string (second args))))
+ (if (and (integerp len) (plusp len))
+ (setq *inspect-length* len)
+ (format output-stream "Cannot set print limit to ~A~%" len))))
+ ;; Select numbered or named component
+ ((or (symbolp option-read)
+ (integerp option-read))
+ (if *inspect-stack*
+ (multiple-value-bind (position list-type elements)
+ (find-object-component (car *inspect-stack*) option-read)
+ (cond
+ ((integerp position)
+ (let* ((element (elt elements position))
+ (value (if (eq list-type :named) (cdr element) element)))
+ (cond ((eq value *inspect-unbound-object-marker*)
+ (format output-stream "That slot is unbound~%"))
+ (t
+ (push value *inspect-stack*)
+ (push option-read *parent-select-stack*)
+ (%inspect output-stream)))))
+ ((null elements)
+ (format output-stream "Object does not contain any subobjects~%"))
+ (t
+ (typecase option-read
+ (symbol
+ (format output-stream
+ "Object has no selectable component named ~A"
+ option))
+ (integer
+ (format output-stream
+ "Object has no selectable component indexed by ~d~&Enter a valid index (~:[0-~W~;0~])~%"
+ option-read
+ (= (length elements) 1)
+ (1- (length elements))))))))
+ (%inspect output-stream)))
+ ;; Default is to select eval'd form
+ (t
+ (reset-stack)
+ (setq *inspect-stack* (list (eval option-read)))
+ (setq *parent-select-stack* (list ":i <form>"))
+ (%inspect output-stream))
+ )))
+
+(defun find-object-component (object id)
+ "COMPONENT-ID can be an integer or a name of a id.
+Returns POSITION LIST-TYPE ELEMENTS
+POSITION is NIL if the id is invalid or not found."
+ (if object
+ (multiple-value-bind (description list-type elements)
+ (inspected-parts object)
+ (declare (ignore description)
+ (list elements))
+ (when (symbolp id)
+ (setq id (symbol-name id)))
+ (let ((position
+ (cond ((and (eq list-type :named)
+ (stringp id))
+ (position id elements :key #'car :test #'string-equal))
+ ((numberp id)
+ (when (< -1 id (length elements))
+ id)))))
+ (values position list-type elements)))
+ (values nil nil nil)))
+
+
+(defun %inspect (s &optional (skip 0))
+ (if *inspect-stack*
+ (progn
+ (setq *inspected* (car *inspect-stack*))
+ (setq cl:* *inspected*)
+ (multiple-value-bind (description list-type elements) (inspected-parts *inspected*)
+ (display-inspected-parts *inspected* description list-type elements s skip)))
+ (format s "No object is being inspected")))
+
+
+(defun display-inspected-parts (object description list-type elements stream &optional (skip 0))
+ (format stream "~&~A" description)
+ (unless (or (characterp object) (typep object 'fixnum))
+ (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
+ (princ #\newline stream)
+ (when elements
+ (do* ((index skip (1+ index))
+ (nelem (length elements))
+ (max (min (1- nelem) (+ skip *inspect-length*)))
+ (suspension (when (plusp (- nelem max))
+ (- nelem max)))
+ (count (if (typep elements 'sequence)
+ (length elements)
+ 0))
+ (element))
+ ((> index max))
+ (declare (ignore suspension)) ;; FIXME - not yet implemented
+ (setq element (elt elements index))
+ (cond
+ ((eq list-type :index-with-tail)
+ (if (eql index (- count 1))
+ (format stream "~4,' D ~A~%" "tail" (inspected-parts element :description t))
+ (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))
+ ((eq list-type :named)
+ (destructuring-bind (name . value) element
+ (format stream "~4,' D ~16,1,1,'-A> ~A~%" index (format nil "~A " name)
+ (if (eq value *inspect-unbound-object-marker*)
+ "..unbound.."
+ (inspected-parts value :description t)))))
+ (t
+ (format stream "~4,' D ~A~%" index (inspected-parts element :description t)))))))
+
+) ;; end binding for multithreading
+
+
+\f
+;;;; INSPECTED-PARTS
+
+;;; Destructure an object for inspection, returning
+;;; (VALUES DESCRIPTION LIST-TYPE ELEMENTS),
+;;; where..
+;;;
+;;; DESCRIPTION is a summary description of the destructured object,
+;;; e.g. "the object is a CONS.~%".
+;;;
+;;; LIST-TYPE determines what representation is used for elements
+;;; of ELEMENTS.
+;;; If LIST-TYPE is :named, then each element is (CONS NAME VALUE)
+;;; If LIST-TYPE is :index-with-tail, then each element is just value,
+;;; but the last element is marked as "tail"
+;;; If LIST-TYPE is :long, then each element is just value,
+;;; and suspension points ('...) are shown before the last element.
+;;; otherwise, each element is just VALUE.
+;;;
+;;; ELEMENTS is a list of the component parts of OBJECT (whose
+;;; representation is determined by LIST-TYPE).
+;;;
+;;; (LIST-TYPE is useful because symbols and instances
+;;; need to display both a slot name and a value, while lists and
+;;; vectors need only display a value.)
+
+(defgeneric inspected-parts (object &key description))
+
+(defmethod inspected-parts ((object symbol) &key description)
+ (let ((desc (format nil "the symbol ~A" object (sb-kernel:get-lisp-obj-address object))))
+ (if description
+ desc
+ (values desc :named
+ (list (cons "name" (symbol-name object))
+ (cons "package" (symbol-package object))
+ (cons "value" (if (boundp object)
+ (symbol-value object)
+ *inspect-unbound-object-marker*))
+ (cons "function" (if (fboundp object)
+ (symbol-function object)
+ *inspect-unbound-object-marker*))
+ (cons "plist" (symbol-plist object)))))))
+
+(defun inspected-structure-elements (object)
+ (let ((parts-list '())
+ (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
+ (when (sb-kernel::defstruct-description-p info)
+ (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse parts-list))
+ (push (cons (sb-kernel:dsd-%name dd-slot)
+ (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
+ parts-list)))))
+
+(defmethod inspected-parts ((object structure-object) &key description)
+ (let ((desc (format nil "~W" (find-class (type-of object)))))
+ (if description
+ desc
+ (values desc :named (inspected-structure-elements object)))))
+
+(defmethod inspected-parts ((object package) &key description)
+ (let ((desc (format nil "the ~A package" (package-name object))))
+ (if description
+ desc
+ (values desc :named (inspected-structure-elements object)))))
+
+(defun inspected-standard-object-elements (object)
+ (let ((reversed-elements nil)
+ (class-slots (sb-pcl::class-slots (class-of object))))
+ (dolist (class-slot class-slots (nreverse reversed-elements))
+ (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
+ (slot-value (if (slot-boundp object slot-name)
+ (slot-value object slot-name)
+ *inspect-unbound-object-marker*)))
+ (push (cons slot-name slot-value) reversed-elements)))))
+
+(defmethod inspected-parts ((object standard-object) &key description)
+ (let ((desc (format nil "~W" (class-of object))))
+ (if description
+ desc
+ (values desc :named
+ (inspected-standard-object-elements object)))))
+
+(defmethod inspected-parts ((object sb-kernel:funcallable-instance) &key description)
+ (let ((desc (format nil "a funcallable-instance of type ~S"
+ (type-of object))))
+ (if description
+ desc
+ (values desc :named
+ (inspected-structure-elements object)))))
+
+(defmethod inspected-parts ((object function) &key description)
+ (let* ((type (sb-kernel:widetag-of object))
+ (object (if (= type sb-vm:closure-header-widetag)
+ (sb-kernel:%closure-fun object)
+ object))
+ (desc (format nil "~S" object)))
+ (if description
+ desc
+ (values desc :named
+ (list (cons "arglist" (sb-kernel:%simple-fun-arglist object)))))))
+
+(defmethod inspected-parts ((object vector) &key description)
+ (let ((desc (format nil
+ "a ~:[~;displaced ~]vector (~W)"
+ (and (sb-kernel:array-header-p object)
+ (sb-kernel:%array-displaced-p object))
+ (length object)
+ (sb-kernel:get-lisp-obj-address object))))
+ (if description
+ desc
+ (values desc nil object))))
+
+(defun inspected-index-string (index rev-dimensions)
+ (if (null rev-dimensions)
+ "[]"
+ (let ((list nil))
+ (dolist (dim rev-dimensions)
+ (multiple-value-bind (q r) (floor index dim)
+ (setq index q)
+ (push r list)))
+ (format nil "[~W~{,~W~}]" (car list) (cdr list)))))
+
+(defmethod inspected-parts ((object simple-vector) &key description)
+ (let ((desc (format nil "a simple ~A vector (~D)"
+ (array-element-type object)
+ (length object))))
+ (if description
+ desc
+ (values desc nil object))))
+
+(defmethod inspected-parts ((object array) &key description)
+ (declare (array object))
+ (let* ((length (array-total-size object))
+ (reference-array (make-array length :displaced-to object))
+ (dimensions (array-dimensions object))
+ (reversed-elements nil)
+ (desc (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
+ (and (sb-kernel:array-header-p object)
+ (sb-kernel:%array-displaced-p object))
+ (array-element-type object)
+ dimensions)))
+ (if description
+ desc
+ (progn
+ (dotimes (i length)
+ (push (cons (format nil "~A "
+ (inspected-index-string i (reverse dimensions)))
+ (aref reference-array i))
+ reversed-elements))
+ (values desc :named (nreverse reversed-elements))))))
+
+(defmethod inspected-parts ((object cons) &key description)
+ (if (or (consp (cdr object)) (null (cdr object)))
+ (inspected-parts-of-nontrivial-list object description)
+ (inspected-parts-of-simple-cons object description)))
+
+(defun inspected-parts-of-simple-cons (object description)
+ (let ((desc (format nil "a cons pair")))
+ (if description
+ desc
+ (values desc :named
+ (list (cons "car" (car object))
+ (cons "cdr" (cdr object)))))))
+
+(defun inspected-parts-of-nontrivial-list (object description)
+ (let ((length 0)
+ (in-list object)
+ (reversed-elements nil))
+ (flet ((done (description-format list-type)
+ (let ((desc (format nil description-format length length)))
+ (return-from inspected-parts-of-nontrivial-list
+ (if description
+ desc
+ (values desc list-type (nreverse reversed-elements)))))))
+ (loop
+ (cond ((null in-list)
+ (done "a proper list with ~D element~P" nil))
+ ((consp in-list)
+ (push (pop in-list) reversed-elements)
+ (incf length))
+ (t
+ (push in-list reversed-elements)
+ (done "a improper list with ~D element~P" :index-with-tail)))))))
+
+(defmethod inspected-parts ((object simple-string) &key description)
+ (let ((desc (format nil "a simple-string (~W) ~W" (length object) object)))
+ (if description
+ desc
+ (values desc nil object))))
+
+(defmethod inspected-parts ((object double-float) &key description)
+ (let ((desc (format nil "double-float ~W" object)))
+ (if description
+ desc
+ (values desc nil nil))))
+
+(defmethod inspected-parts ((object single-float) &key description)
+ (let ((desc (format nil "single-float ~W" object)))
+ (if description
+ desc
+ (values desc nil nil))))
+
+(defmethod inspected-parts ((object fixnum) &key description)
+ (let ((desc (format nil "fixnum ~W" object)))
+ (if description
+ desc
+ (values desc nil nil))))
+
+(defmethod inspected-parts ((object complex) &key description)
+ (let ((desc (format nil "complex number ~W" object)))
+ (if description
+ desc
+ (values desc :named
+ (list (cons "real" (realpart object))
+ (cons "imag" (imagpart object)))))))
+
+(defmethod inspected-parts ((object bignum) &key description)
+ (let ((desc (format nil "bignum ~W" object)))
+ (if description
+ desc
+ (values desc nil nil))))
+
+(defmethod inspected-parts ((object ratio) &key description)
+ (let ((desc (format nil "ratio ~W" object)))
+ (if description
+ desc
+ (values desc :named
+ (list (cons "numerator" (numerator object))
+ (cons "denominator" (denominator object)))))))
+
+(defmethod inspected-parts ((object character) &key description)
+ (let ((desc (format nil "character ~W char-code #x~X" object (char-code object))))
+ (if description
+ desc
+ (values desc nil nil))))
+
+(defmethod inspected-parts ((object t) &key description)
+ (let ((desc (format nil "a generic object ~W" object)))
+ (if description
+ desc
+ (values desc nil nil))))
--- /dev/null
+;;;; 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:defpackage :sb-aclrepl
+ (:use :cl :sb-ext)
+ (:export #:*prompt* #:*exit-on-eof* #:*max-history*
+ #:*use-short-package-name* #:*command-char*
+ #:alias))
+
+(cl:in-package :sb-aclrepl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *default-prompt* "~&~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* 24
+ "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")
+
+(declaim (type list *history*))
+
+(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
+
+(defvar *eof-marker* (cons :eof nil))
+(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))
+
+;; Set up binding for multithreading
+
+(let ((*prompt* #.*default-prompt*)
+ (*use-short-package-name* t)
+ (*dir-stack* nil)
+ (*command-char* #\:)
+ (*max-history* 24)
+ (*exit-on-eof* t)
+ (*history* nil)
+ (*cmd-number* 1))
+
+(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
+ (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)))
+ (loop as arg = (read string-stream nil *eof-marker*)
+ until (eq arg *eof-marker*)
+ collect arg))))))
+ (let ((next-char (peek-char-non-whitespace input-stream)))
+ (cond
+ ((eql next-char *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 (string line))
+ (if (numberp (read-from-string cmd-string))
+ (let ((cmd (get-history (read-from-string cmd-string))))
+ (if (eq cmd *null-cmd*)
+ (make-user-cmd :func :history-error
+ :input (read-from-string cmd-string))
+ (make-user-cmd :func (user-cmd-func cmd)
+ :input (user-cmd-input cmd)
+ :args (user-cmd-args cmd)
+ :hnum *cmd-number*)))
+ (let ((cmd-entry (find-cmd cmd-string)))
+ (if cmd-entry
+ (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*)
+ (make-user-cmd :func :cmd-error
+ :input cmd-string)
+ )))))
+ ((eql next-char #\newline)
+ (read-char input-stream)
+ *null-cmd*)
+ (t
+ (let ((form (read input-stream nil *eof-marker*)))
+ (if (eq form *eof-marker*)
+ *eof-cmd*
+ (make-user-cmd :input form :func nil :hnum *cmd-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)
+
+(defun make-cte (name-param func desc parsing group)
+ (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)))
+
+(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))
+
+(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* (+ (length *history*) *max-history* 1))))
+ (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
+ (eql (length k) (length (cmd-table-entry-name v)))
+ (eq (cmd-table-entry-group v) group))
+ (push (list k (cmd-table-entry-desc v)) cmds)))
+ *cmd-table-hash*)
+ (sort cmds #'string-lessp :key #'car)))
+
+(defun cd-cmd (output-stream &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-stream "~A~%" (namestring cl:*default-pathname-defaults*))
+ (values))
+
+(defun pwd-cmd (output-stream)
+ (format output-stream "Lisp's current working directory is ~s.~%"
+ (namestring cl:*default-pathname-defaults*))
+ (values))
+
+(defun trace-cmd (output-stream &rest args)
+ (if args
+ (format output-stream "~A~%" (eval (sb-debug::expand-trace args)))
+ (format output-stream "~A~%" (sb-debug::%list-traced-funs)))
+ (values))
+
+(defun untrace-cmd (output-stream &rest args)
+ (if args
+ (format output-stream "~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-stream "~A~%" (eval (sb-debug::untrace-all))))
+ (values))
+
+(defun exit-cmd (output-stream &optional (status 0))
+ (declare (ignore output-stream))
+ (quit :unix-status status)
+ (values))
+
+(defun package-cmd (output-stream &optional pkg)
+ (cond
+ ((null pkg)
+ (format output-stream "The ~A package is current.~%"
+ (package-name cl:*package*)))
+ ((null (find-package (write-to-string pkg)))
+ (format output-stream "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."
+ (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 (output-stream &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-stream "loading ~a~%" arg)
+ (load arg)))
+ (values))
+
+(defun cf-cmd (output-stream string-files)
+ (declare (ignore output-stream))
+ (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))
+\f
+;;;; implementation of commands
+
+(defun apropos-cmd (output-stream string)
+ (declare (ignore output-stream))
+ (apropos (string-upcase string))
+ (values))
+
+(let ((last-files-loaded nil))
+ (defun cload-cmd (output-stream &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-stream "loading ~a~%" arg)
+ (load (compile-file-as-needed arg)))
+ (values)))
+
+(defun inspect-cmd (output-stream arg)
+ (inspector arg nil output-stream)
+ (values))
+
+(defun istep-cmd (output-stream &optional arg-string)
+ (istep arg-string output-stream)
+ (values))
+
+(defun describe-cmd (output-stream &rest args)
+ (declare (ignore output-stream))
+ (dolist (arg args)
+ (eval `(describe ,arg)))
+ (values))
+
+(defun macroexpand-cmd (output-stream arg)
+ (pprint (macroexpand arg) output-stream)
+ (values))
+
+(defun history-cmd (output-stream)
+ (let ((n (length *history*)))
+ (declare (fixnum n))
+ (dotimes (i n)
+ (declare (fixnum i))
+ (let ((hist (nth (- n i 1) *history*)))
+ (format output-stream "~3A ~A~%" (user-cmd-hnum hist)
+ (user-cmd-input hist)))))
+ (values))
+
+(defun help-cmd (output-stream &optional cmd)
+ (cond
+ (cmd
+ (let ((cmd-entry (find-cmd cmd)))
+ (if cmd-entry
+ (format output-stream "Documentation for ~A: ~A~%"
+ (cmd-table-entry-name cmd-entry)
+ (cmd-table-entry-desc cmd-entry)))))
+ (t
+ (format output-stream "~13A ~a~%" "Command" "Description")
+ (format output-stream "------------- -------------~%")
+ (format output-stream "~13A ~A~%" "n"
+ "(for any number n) recall nth command from history list")
+ (dolist (doc-entry (get-cmd-doc-list :cmd))
+ (format output-stream "~13A ~A~%" (car doc-entry) (cadr doc-entry)))))
+ (values))
+
+(defun alias-cmd (output-stream)
+ (let ((doc-entries (get-cmd-doc-list :alias)))
+ (typecase doc-entries
+ (cons
+ (format output-stream "~13A ~a~%" "Alias" "Description")
+ (format output-stream "------------- -------------~%")
+ (dolist (doc-entry doc-entries)
+ (format output-stream "~13A ~A~%" (car doc-entry) (cadr doc-entry))))
+ (t
+ (format output-stream "No aliases are defined~%"))))
+ (values))
+
+(defun shell-cmd (output-stream string-arg)
+ (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
+ :input nil :output output-stream)
+ (values))
+
+(defun pushd-cmd (output-stream string-arg)
+ (push string-arg *dir-stack*)
+ (cd-cmd output-stream string-arg)
+ (values))
+
+(defun popd-cmd (output-stream)
+ (if *dir-stack*
+ (let ((dir (pop *dir-stack*)))
+ (cd-cmd dir))
+ (format output-stream "No directory on stack to pop.~%"))
+ (values))
+
+(defun dirs-cmd (output-stream)
+ (dolist (dir *dir-stack*)
+ (format output-stream "~a~%" dir))
+ (values))
+\f
+;;;; dispatch table for commands
+
+(let ((cmd-table
+ '(("aliases" 3 alias-cmd "show aliases")
+ ("apropos" 2 apropos-cmd "show apropos" :parsing :string)
+ ("cd" 2 cd-cmd "change default diretory" :parsing :string)
+ ("ld" 2 ld-cmd "load a file" :parsing :string)
+ ("cf" 2 cf-cmd "compile file" :parsing :string)
+ ("cload" 2 cload-cmd "compile if needed and load file"
+ :parsing :string)
+ ("describe" 2 describe-cmd "describe an object")
+ ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
+ ("package" 2 package-cmd "change current package")
+ ("exit" 2 exit-cmd "exit sbcl")
+ ("help" 2 help-cmd "print this help")
+ ("history" 3 history-cmd "print the recent history")
+ ("inspect" 2 inspect-cmd "inspect an object")
+ ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
+ ("pwd" 3 pwd-cmd "print current directory")
+ ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
+ ("popd" 2 popd-cmd "pop directory from stack")
+ ("trace" 2 trace-cmd "trace a function")
+ ("untrace" 4 untrace-cmd "untrace a function")
+ ("dirs" 2 dirs-cmd "show directory stack")
+ ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string))))
+ (dolist (cmd cmd-table)
+ (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
+ (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
+\f
+;;;; machinery for aliases
+
+(defsetf alias (name) (user-func)
+ `(progn
+ (%add-entry
+ (make-cte (quote ,name) ,user-func "" nil :alias))
+ (quote ,name)))
+
+(defmacro alias (name-param args &rest body)
+ (let ((parsing nil)
+ (desc "")
+ (abbr-index nil)
+ (name (if (atom name-param)
+ name-param
+ (car name-param))))
+ (when (consp name-param)
+ (dolist (param (cdr name-param))
+ (cond
+ ((or
+ (eq param :case-sensitive)
+ (eq param :string))
+ (setq parsing param))
+ ((stringp param)
+ (setq desc param))
+ ((numberp param)
+ (setq abbr-index param)))))
+ `(progn
+ (%add-entry
+ (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias)
+ ,abbr-index)
+ ,name)))
+
+
+(defun remove-alias (&rest aliases)
+ (declare (list aliases))
+ (let ((keys '())
+ (remove-all (not (null (find :all aliases)))))
+ (unless remove-all ;; ensure all alias are strings
+ (setq aliases
+ (loop for alias in aliases
+ collect
+ (etypecase alias
+ (string
+ alias)
+ (symbol
+ (symbol-name alias))))))
+ (maphash
+ (lambda (key cmd)
+ (when (eq (cmd-table-entry-group cmd) :alias)
+ (if remove-all
+ (push key keys)
+ (when (some
+ (lambda (alias)
+ (let ((klen (length key)))
+ (and (>= (length alias) klen)
+ (string-equal (subseq alias 0 klen)
+ (subseq key 0 klen)))))
+ aliases)
+ (push key keys)))))
+ *cmd-table-hash*)
+ (dolist (key keys)
+ (remhash key *cmd-table-hash*))
+ keys))
+\f
+;;;; low-level reading/parsing functions
+
+;;; Skip white space (but not #\NEWLINE), and peek at the next
+;;; character.
+(defun peek-char-non-whitespace (&optional stream)
+ (do ((char (peek-char nil stream nil *eof-marker*)
+ (peek-char nil stream nil *eof-marker*)))
+ ((not (whitespace-char-not-newline-p char)) char)
+ (read-char stream)))
+
+(defun string-trim-whitespace (str)
+ (string-trim '(#\space #\tab #\return)
+ str))
+
+(defun whitespace-char-not-newline-p (x)
+ (and (characterp x)
+ (or (char= x #\space)
+ (char= x #\tab)
+ (char= x #\return))))
+
+\f
+;;;; linking into SBCL hooks
+
+(defun repl-prompt-fun (stream)
+ (if (functionp *prompt*)
+ (write-string (funcall *prompt* (prompt-package-name) *cmd-number*)
+ stream)
+ (format stream *prompt* (prompt-package-name) *cmd-number*)))
+
+(defun process-cmd (user-cmd output-stream)
+ ;; Processes a user command. Returns t if the user-cmd was a top-level
+ ;; command
+ (cond ((eq user-cmd *eof-cmd*)
+ (when *exit-on-eof*
+ (quit))
+ (format output-stream "EOF~%")
+ t)
+ ((eq user-cmd *null-cmd*)
+ t)
+ ((eq (user-cmd-func user-cmd) :cmd-error)
+ (format output-stream "Unknown top-level command: ~s.~%"
+ (user-cmd-input user-cmd))
+ (format output-stream "Type `:help' for the list of commands.~%")
+ t)
+ ((eq (user-cmd-func user-cmd) :history-error)
+ (format output-stream "Input numbered ~d is not on the history list~%"
+ (user-cmd-input user-cmd))
+ t)
+ ((functionp (user-cmd-func user-cmd))
+ (add-to-history user-cmd)
+ (apply (user-cmd-func user-cmd) output-stream (user-cmd-args user-cmd))
+ (fresh-line)
+ t)
+ (t
+ (add-to-history user-cmd)
+ nil))) ; nope, not in my job description
+
+(defun repl-read-form-fun (input-stream output-stream)
+ ;; Pick off all the leading ACL magic commands, then return a normal
+ ;; Lisp form.
+ (loop for user-cmd = (read-cmd input-stream) do
+ (if (process-cmd user-cmd output-stream)
+ (progn
+ (repl-prompt-fun output-stream)
+ (force-output output-stream))
+ (return (user-cmd-input user-cmd)))))
+
+
+(setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
+ sb-int:*repl-read-form-fun* #'repl-read-form-fun)
+
+) ;; close special variables bindings
+
--- /dev/null
+;;; -*- Lisp -*-
+
+(defpackage #:sb-aclrepl-system (:use #:asdf #:cl))
+(in-package #:sb-aclrepl-system)
+
+(defsystem sb-aclrepl
+ :version "0.5"
+ :components ((:file "repl")
+ (:file "inspect" :depends-on ("repl"))))
+
+++ /dev/null
-;;;; 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:defpackage :sb-aclrepl
- (:use :cl :sb-ext)
- ;; FIXME: should we be exporting anything else?
- (:export #:*prompt* #:*exit-on-eof* #:*max-history*
- #:*use-short-package-name* #:*command-char*
- #:alias))
-
-(cl:in-package :sb-aclrepl)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter *default-prompt* "~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* 24
- "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* 0
- "Number of the current command")
-
-(defstruct user-cmd
- (input nil) ; input, maybe a string or form
- (func nil) ; cmd func entered, overloaded (:eof :null-cmd))
- (args nil) ; args for cmd func
- (hnum nil)) ; history number
-
-(defvar *eof-marker* (cons :eof nil))
-(defvar *eof-cmd* (make-user-cmd :func :eof))
-(defvar *null-cmd* (make-user-cmd :func :null-cmd))
-
-(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)
- (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)))
- (loop as arg = (read string-stream nil *eof-marker*)
- until (eq arg *eof-marker*)
- collect arg))))))
- (let ((next-char (peek-char-non-whitespace input-stream)))
- (cond
- ((eql next-char *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))
- "")))
- (if (numberp (read-from-string cmd-string))
- (let ((cmd (get-history (read-from-string cmd-string))))
- (when cmd
- (make-user-cmd :func (user-cmd-func cmd)
- :input (user-cmd-input cmd)
- :args (user-cmd-args cmd)
- :hnum *cmd-number*)))
- (let ((cmd-entry (find-cmd cmd-string)))
- (if cmd-entry
- (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*)
- (progn
- (format t "Unknown top-level command: ~s.~%" cmd-string)
- (format t "Type `:help' for the list of commands.~%")
- *null-cmd*
- ))))))
- ((eql next-char #\newline)
- (read-char input-stream)
- *null-cmd*)
- (t
- (let ((form (read input-stream nil *eof-marker*)))
- (if (eq form *eof-marker*)
- *eof-cmd*
- (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
-
-(defparameter *cmd-table-hash*
- (make-hash-table :size 30 :test #'equal))
-
-;;; 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)
-
-(defun make-cte (name-param func desc parsing group)
- (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)))
-
-(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))
-
-(defun find-cmd (cmdstr)
- (gethash (string-downcase cmdstr) *cmd-table-hash*))
-
-(defun user-cmd= (c1 c2)
- "Returns T if two user commands are equal"
- (if (or (not (user-cmd-p c1)) (not (user-cmd-p c2)))
- (progn
- (format t "Error: ~s or ~s is not a user-cmd" c1 c2)
- nil)
- (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* (+ (length *history*) *max-history* 1))))
- (push cmd *history*)))
-
-(defun get-history (n)
- (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql)))
- (if cmd
- cmd
- (progn
- (format t "Input numbered ~A is not on the history list.." n)
- *null-cmd*))))
-
-(defun get-cmd-doc-list (&optional (group :cmd))
- "Return list of all commands"
- (let ((cmds '()))
- (maphash (lambda (k v)
- (when (and
- (eql (length k) (length (cmd-table-entry-name v)))
- (eq (cmd-table-entry-group v) group))
- (push (list k (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 t "~A~%" (namestring cl:*default-pathname-defaults*))
- (values))
-
-(defun pwd-cmd ()
- (format t "Lisp's current working directory is ~s.~%"
- (namestring cl:*default-pathname-defaults*))
- (values))
-
-(defun trace-cmd (&rest args)
- (if args
- (format t "~A~%" (eval (apply #'sb-debug::expand-trace args)))
- (format t "~A~%" (sb-debug::%list-traced-funs)))
- (values))
-
-(defun untrace-cmd (&rest args)
- (if args
- (format t "~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 t "~A~%" (eval (sb-debug::untrace-all))))
- (values))
-
-(defun exit-cmd (&optional (status 0))
- (quit :unix-status status)
- (values))
-
-(defun package-cmd (&optional pkg)
- (cond
- ((null pkg)
- (format t "The ~A package is current.~%" (package-name cl:*package*)))
- ((null (find-package (write-to-string pkg)))
- (format t "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."
- (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))
-
-(defun ld-cmd (string-files)
- (dolist (arg (string-to-list-skip-spaces string-files))
- (format t "loading ~a~%" arg)
- (load arg))
- (values))
-
-(defun cf-cmd (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))
-\f
-;;;; implementation of commands
-
-(defun cload-cmd (string-files)
- (dolist (arg (string-to-list-skip-spaces string-files))
- (load (compile-file-as-needed arg)))
- (values))
-
-(defun inspect-cmd (arg)
- (eval `(inspect ,arg))
- (values))
-
-(defun describe-cmd (&rest args)
- (dolist (arg args)
- (eval `(describe ,arg)))
- (values))
-
-(defun macroexpand-cmd (arg)
- (pprint (macroexpand arg))
- (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 t "~3A ~A~%" (user-cmd-hnum hist) (user-cmd-input hist)))))
- (values))
-
-(defun help-cmd (&optional cmd)
- (cond
- (cmd
- (let ((cmd-entry (find-cmd cmd)))
- (if cmd-entry
- (format t "Documentation for ~A: ~A~%"
- (cmd-table-entry-name cmd-entry)
- (cmd-table-entry-desc cmd-entry)))))
- (t
- (format t "~13A ~a~%" "Command" "Description")
- (format t "------------- -------------~%")
- (format t "~13A ~A~%" "n" "(for any number n) recall nth command from history list")
- (dolist (doc-entry (get-cmd-doc-list :cmd))
- (format t "~13A ~A~%" (car doc-entry) (cadr doc-entry)))))
- (values))
-
-(defun alias-cmd ()
- (let ((doc-entries (get-cmd-doc-list :alias)))
- (typecase doc-entries
- (cons
- (format t "~13A ~a~%" "Alias" "Description")
- (format t "------------- -------------~%")
- (dolist (doc-entry doc-entries)
- (format t "~13A ~A~%" (car doc-entry) (cadr doc-entry))))
- (t
- (format t "No aliases are defined~%"))))
- (values))
-
-(defun shell-cmd (string-arg)
- (sb-ext:run-program "/bin/sh" (list "-c" string-arg)
- :input nil :output *trace-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 t "No directory on stack to pop.~%"))
- (values))
-
-(defun dirs-cmd ()
- (dolist (dir *dir-stack*)
- (format t "~a~%" dir))
- (values))
-\f
-;;;; dispatch table for commands
-
-(let ((cmd-table
- '(("aliases" 3 alias-cmd "show aliases")
- ("cd" 2 cd-cmd "change default diretory" :parsing :string)
- ("ld" 2 ld-cmd "load a file" :parsing :string)
- ("cf" 2 cf-cmd "compile file" :parsing :string)
- ("cload" 2 cload-cmd "compile if needed and load file"
- :parsing :string)
- ("describe" 2 describe-cmd "describe an object")
- ("macroexpand" 2 macroexpand-cmd "macroexpand an expression")
- ("package" 2 package-cmd "change current package")
- ("exit" 2 exit-cmd "exit sbcl")
- ("help" 2 help-cmd "print this help")
- ("history" 3 history-cmd "print the recent history")
- ("inspect" 2 inspect-cmd "inspect an object")
- ("pwd" 3 pwd-cmd "print current directory")
- ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string)
- ("popd" 2 popd-cmd "pop directory from stack")
- ("trace" 2 trace-cmd "trace a function")
- ("untrace" 4 untrace-cmd "untrace a function")
- ("dirs" 2 dirs-cmd "show directory stack")
- ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string))))
- (dolist (cmd cmd-table)
- (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd
- (add-cmd-table-entry cmd-string abbr-len func-name desc parsing))))
-\f
-;;;; machinery for aliases
-
-(defsetf alias (name) (user-func)
- `(progn
- (%add-entry
- (make-cte (quote ,name) ,user-func "" nil :alias))
- (quote ,name)))
-
-(defmacro alias (name-param args &rest body)
- (let ((parsing nil)
- (desc "")
- (abbr-index nil)
- (name (if (atom name-param)
- name-param
- (car name-param))))
- (when (consp name-param)
- (dolist (param (cdr name-param))
- (cond
- ((or
- (eq param :case-sensitive)
- (eq param :string))
- (setq parsing param))
- ((stringp param)
- (setq desc param))
- ((numberp param)
- (setq abbr-index param)))))
- `(progn
- (%add-entry
- (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias)
- ,abbr-index)
- ,name)))
-
-
-(defun remove-alias (&rest aliases)
- (let ((keys '())
- (remove-all (not (null (find :all aliases)))))
- (unless remove-all ;; ensure all alias are strings
- (setq aliases
- (loop for alias in aliases
- collect
- (etypecase alias
- (string
- alias)
- (symbol
- (symbol-name alias))))))
- (maphash
- (lambda (key cmd)
- (when (eq (cmd-table-entry-group cmd) :alias)
- (if remove-all
- (push key keys)
- (when (some
- (lambda (alias)
- (let ((klen (length key)))
- (and (>= (length alias) klen)
- (string-equal (subseq alias 0 klen)
- (subseq key 0 klen)))))
- aliases)
- (push key keys)))))
- *cmd-table-hash*)
- (dolist (key keys)
- (remhash key *cmd-table-hash*))
- keys))
-\f
-;;;; low-level reading/parsing functions
-
-;;; Skip white space (but not #\NEWLINE), and peek at the next
-;;; character.
-(defun peek-char-non-whitespace (&optional stream)
- (do ((char (peek-char nil stream nil *eof-marker*)
- (peek-char nil stream nil *eof-marker*)))
- ((not (whitespace-char-not-newline-p char)) char)
- (read-char stream)))
-
-(defun string-trim-whitespace (str)
- (string-trim '(#\space #\tab #\return)
- str))
-
-(defun whitespace-char-not-newline-p (x)
- (and (characterp x)
- (or (char= x #\space)
- (char= x #\tab)
- (char= x #\return))))
-\f
-;;;; linking into SBCL hooks
-
-(defun repl-prompt-fun (stream)
- (incf *cmd-number*)
- (fresh-line stream)
- (if (functionp *prompt*)
- (write-string (funcall *prompt* (prompt-package-name) *cmd-number*)
- stream)
- (format stream *prompt* (prompt-package-name) *cmd-number*)))
-
-;;; If USER-CMD is to be processed as something magical (not an
-;;; ordinary eval-and-print-me form) then do so and return non-NIL.
-(defun execute-as-acl-magic (user-cmd input-stream output-stream)
- ;; kludgity kludge kludge kludge ("and then a miracle occurs")
- ;;
- ;; This is a really sloppy job of smashing KMR's code (what he
- ;; called DEFUN REP-ONE-CMD) onto DB's hook ideas, not even doing
- ;; the basics like passing INPUT-STREAM and OUTPUT-STREAM into the
- ;; KMR code. A real implementation might want to do rather better.
- (cond ((eq user-cmd *eof-cmd*)
- (decf *cmd-number*)
- (when *exit-on-eof*
- (quit))
- (format t "EOF~%")
- t) ; Yup, we knew how to handle that.
- ((eq user-cmd *null-cmd*)
- (decf *cmd-number*)
- t) ; Yup.
- ((functionp (user-cmd-func user-cmd))
- (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd))
- (add-to-history user-cmd)
- (fresh-line)
- t) ; Ayup.
- (t
- (add-to-history user-cmd)
- nil))) ; nope, not in my job description
-
-(defun repl-read-form-fun (input-stream output-stream)
- ;; Pick off all the leading ACL magic commands, then return a normal
- ;; Lisp form.
- (loop for user-cmd = (read-cmd input-stream) do
- (if (execute-as-acl-magic user-cmd input-stream output-stream)
- (progn
- (repl-prompt-fun output-stream)
- (force-output output-stream))
- (return (user-cmd-input user-cmd)))))
-
-(setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
- sb-int:*repl-read-form-fun* #'repl-read-form-fun)
projects / sbcl.git / commitdiff