From: Kevin Rosenberg Date: Sat, 5 Apr 2003 20:51:43 +0000 (+0000) Subject: Add inspector X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=83c1b8bca82fc165b01332ef9e5c031c64d758d8;p=sbcl.git Add inspector --- diff --git a/contrib/sb-aclrepl/Makefile b/contrib/sb-aclrepl/Makefile index ca35df7..b4c4ac0 100644 --- a/contrib/sb-aclrepl/Makefile +++ b/contrib/sb-aclrepl/Makefile @@ -1,5 +1,2 @@ MODULE=sb-aclrepl -include ../vanilla-module.mk - -test:: - true +include ../asdf-module.mk diff --git a/contrib/sb-aclrepl/README b/contrib/sb-aclrepl/README new file mode 100644 index 0000000..7a8161c --- /dev/null +++ b/contrib/sb-aclrepl/README @@ -0,0 +1,6 @@ +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 +. diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp new file mode 100644 index 0000000..200202a --- /dev/null +++ b/contrib/sb-aclrepl/inspect.lisp @@ -0,0 +1,552 @@ +;;;; 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: +;;;; . +;;;; +;;;; 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 +
inspect the (eval form) +:i inspect the numbered component of object +:i inspect the named component of object +:i evaluation and inspect form +:i - inspect parent +:i ^ inspect parent +:i < inspect previous parent component +:i > inspect next parent component +:i set set indexed component to evalated form +:i set set named component to evalated form +:i print set the maximum number of components to print +:i skip 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 ")) + (%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 + + + +;;;; 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)))) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp new file mode 100644 index 0000000..cb67b91 --- /dev/null +++ b/contrib/sb-aclrepl/repl.lisp @@ -0,0 +1,550 @@ +;;;; 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: +;;;; . + +(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)) + +;;;; 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)) + +;;;; 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)))) + +;;;; 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)) + +;;;; 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)))) + + +;;;; 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 + diff --git a/contrib/sb-aclrepl/sb-aclrepl.asd b/contrib/sb-aclrepl/sb-aclrepl.asd new file mode 100644 index 0000000..4412870 --- /dev/null +++ b/contrib/sb-aclrepl/sb-aclrepl.asd @@ -0,0 +1,10 @@ +;;; -*- 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")))) + diff --git a/contrib/sb-aclrepl/sb-aclrepl.lisp b/contrib/sb-aclrepl/sb-aclrepl.lisp deleted file mode 100644 index a4d4b4c..0000000 --- a/contrib/sb-aclrepl/sb-aclrepl.lisp +++ /dev/null @@ -1,507 +0,0 @@ -;;;; 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: -;;;; . - -(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)) - -;;;; 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)) - -;;;; 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)))) - -;;;; 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)) - -;;;; 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)))) - -;;;; 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)