--- /dev/null
+;; Tests for sb-aclrepl
+
+(defpackage #:aclrepl-tests (:use #:sb-aclrepl #:cl))
+(in-package #:aclrepl-tests)
+
+(import '(sb-aclrepl::inspected-parts sb-aclrepl::inspected-description
+ sb-aclrepl::inspected-elements sb-aclrepl::parts-count
+ sb-aclrepl::parts-seq-type sb-aclrepl::find-object-part-with-id
+ sb-aclrepl::element-at sb-aclrepl::label-at
+ sb-aclrepl::display-inspected-parts
+ sb-aclrepl::display-labelled-element
+ sb-aclrepl::*inspect-unbound-object-marker*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package 'regression-test)
+ (load (sb-aclrepl::compile-file-as-needed "rt.lisp"))))
+(use-package :regression-test)
+(setf regression-test::*catch-errors* nil)
+
+(rem-all-tests)
+
+(deftest hook.1 (boundp 'sb-impl::*inspect-fun*) t)
+(deftest hook.2 (boundp 'sb-int:*repl-prompt-fun*) t)
+(deftest hook.3 (boundp 'sb-int:*repl-read-form-fun*) t)
+;(deftest (boundp 'sb-debug::*invoke-debugger-fun*) t)
+
+;;; Inspector tests
+
+(defclass empty-class ()
+ ())
+(defparameter *empty-class* (make-instance 'empty-class))
+
+(defclass empty-class ()
+ ())
+
+(defclass simple-class ()
+ ((a)
+ (second :initform 0)
+ (really-long-slot-name :initform "abc")))
+
+(defstruct empty-struct
+ )
+
+(defstruct simple-struct
+ (first)
+ (slot-2 'a-value)
+ (really-long-struct-slot-name "defg"))
+
+(defparameter *empty-class* (make-instance 'empty-class))
+(defparameter *simple-class* (make-instance 'simple-class))
+(defparameter *empty-struct* (make-empty-struct))
+(defparameter *simple-struct* (make-simple-struct))
+(defparameter *normal-list* '(a b 3))
+(defparameter *dotted-list* '(a b . 3))
+(defparameter *cons-pair* '(#c(1 2) . a-symbol))
+(defparameter *complex* #c(1 2))
+(defparameter *ratio* 22/7)
+(defparameter *array* (make-array '(3 3 2) :initial-element nil))
+(defparameter *vector* (make-array '(20):initial-contents
+ '(0 1 2 3 4 5 6 7 8 9
+ 10 11 12 13 14 15 16 17 18 19)))
+
+(defun find-position (object id)
+ (nth-value 0 (find-object-part-with-id object id)))
+(defun parts (object)
+ (inspected-parts object))
+(defun description (object)
+ (inspected-description object))
+(defun elements (object &optional print skip)
+ (nth-value 0 (inspected-elements object print skip)))
+(defun elements-labels (object &optional print skip)
+ (nth-value 1 (inspected-elements object print skip)))
+(defun elements-count (object &optional print skip)
+ (nth-value 2 (inspected-elements object print skip)))
+
+(defun labelled-element (object pos &optional print skip)
+ (with-output-to-string (strm)
+ (display-labelled-element (aref (elements object print skip) pos)
+ (aref (elements-labels object print skip) pos)
+ strm)))
+
+(deftest find.list.0 (find-position *normal-list* 0) 0)
+(deftest find.list.1 (find-position *normal-list* 0) 0)
+(deftest find.list.2 (find-position *normal-list* 1) 1)
+(deftest find.list.3 (find-position *normal-list* 2) 2)
+(deftest parts.list.1 (parts-count (parts *normal-list*)) 3)
+(deftest parts.list.2 (element-at (parts *normal-list*) 0) a)
+(deftest parts.list.3 (element-at (parts *normal-list*) 1) b)
+(deftest parts.list.4 (element-at (parts *normal-list*) 2) 3)
+(deftest parts.list.5 (label-at (parts *normal-list*) 0) 0)
+(deftest parts.list.6 (label-at (parts *normal-list*) 1) 1)
+(deftest parts.list.7 (label-at (parts *normal-list*) 2) 2)
+(deftest parts.list.8 (parts-seq-type (parts *normal-list*)) :list)
+
+(deftest elem.list.0 (elements-count *normal-list*) 3)
+(deftest elem.list.1 (elements *normal-list*) #(a b 3))
+(deftest elem.list.2 (elements-labels *normal-list*) #(0 1 2))
+
+(deftest elem.dotted.0 (elements-count *dotted-list*) 3)
+(deftest elem.dotted.1 (elements *dotted-list*) #(a b 3))
+(deftest elem.dotted.2 (elements-labels *dotted-list*) #(0 1 :tail))
+
+(deftest elem.consp.0 (elements-count *cons-pair*) 2)
+(deftest elem.consp.1 (elements *cons-pair*) #(#c(1 2) a-symbol))
+(deftest elem.consp.2 (elements-labels *cons-pair*)
+ #((0 . "car") (1 . "cdr")))
+
+(deftest elem.complex.0 (elements-count *complex*) 2)
+(deftest elem.complex.1 (elements *complex*) #(1 2))
+(deftest elem.complex.2 (elements-labels *complex*)
+ #((0 . "real") (1 . "imag")))
+
+(deftest elem.ratio.0 (elements-count *ratio*) 2)
+(deftest elem.ratio.1 (elements *ratio*) #(22 7))
+(deftest elem.ratio.2 (elements-labels *ratio*)
+ #((0 . "numerator") (1 . "denominator")))
+
+(deftest elem.vector.0 (elements-count *vector*) 20)
+(deftest elem.vector.1 (elements *vector*)
+ #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
+(deftest elem.vector.2 (elements-labels *vector*)
+ #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
+
+(deftest elem.vector.skip1.0 (elements-count *vector* nil 3) 18)
+(deftest elem.vector.skip1.1 (elements *vector* nil 3)
+ #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
+(deftest elem.vector.skip1.2 (elements-labels *vector* nil 3)
+ #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
+
+(deftest elem.vector.skip2.0 (elements-count *vector* 10 3) 13)
+(deftest elem.vector.skip2.1 (elements *vector* 10 3)
+ #(nil 3 4 5 6 7 8 9 10 11 12 nil 19))
+(deftest elem.vector.skip2.2 (elements-labels *vector* 10 3)
+ #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19))
+
+(deftest elem.vector.skip3.0 (elements-count *vector* 5 16) 5)
+(deftest elem.vector.skip3.1 (elements *vector* 5 16)
+ #(nil 16 17 18 19))
+(deftest elem.vector.skip3.2 (elements-labels *vector* 5 16)
+ #(:ellipses 16 17 18 19))
+
+(deftest elem.vector.skip4.0 (elements-count *vector* 2 16) 5)
+(deftest elem.vector.skip4.1 (elements *vector* 2 16)
+ #(nil 16 17 18 19))
+(deftest elem.vector.skip4.2 (elements-labels *vector* 2 16)
+ #(:ellipses 16 17 18 19))
+
+(deftest elem.vector.skip5.0 (elements-count *vector* 2 15) 5)
+(deftest elem.vector.skip5.1 (elements *vector* 2 15)
+ #(nil 15 16 nil 19))
+(deftest elem.vector.skip5.2 (elements-labels *vector* 2 15)
+ #(:ellipses 15 16 :ellipses 19))
+
+(deftest elem.array.0 (elements-count *array*) 18)
+(deftest elem.array.1 (elements *array*)
+ #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
+ NIL NIL))
+(deftest elem.array.2 (elements-labels *array*)
+ #((0 . "[0,0,0]") (1 . "[0,0,1]") (2 . "[0,1,0]") (3 . "[0,1,1]")
+ (4 . "[0,2,0]") (5 . "[0,2,1]") (6 . "[1,0,0]") (7 . "[1,0,1]")
+ (8 . "[1,1,0]") (9 . "[1,1,1]") (10 . "[1,2,0]")
+ (11 . "[1,2,1]") (12 . "[2,0,0]") (13 . "[2,0,1]")
+ (14 . "[2,1,0]") (15 . "[2,1,1]") (16 . "[2,2,0]")
+ (17 . "[2,2,1]")))
+
+
+(deftest empty.class.0 (elements-count *empty-class*) 0)
+(deftest empty.class.1 (elements *empty-class*) nil)
+(deftest empty.class.2 (elements-labels *empty-class*) nil)
+
+(deftest simple.class.0 (elements-count *simple-class*) 3)
+(deftest simple.class.1 (elements *simple-class*)
+ #(#.*inspect-unbound-object-marker* 0 "abc"))
+(deftest simple.class.2 (elements-labels *simple-class*)
+ #((0 . A) (1 . SECOND) (2 . REALLY-LONG-SLOT-NAME)))
+
+(deftest empty.struct.0 (elements-count *empty-struct*) 0)
+(deftest empty.struct.1 (elements *empty-struct*) nil)
+(deftest empty.struct.2 (elements-labels *empty-struct*) nil)
+
+(deftest simple.struct.0 (elements-count *simple-struct*) 3)
+(deftest simple.struct.1 (elements *simple-struct*)
+ #(nil a-value "defg"))
+(deftest simple.struct.2 (elements-labels *simple-struct*)
+ #((0 . "FIRST") (1 . "SLOT-2")
+ (2 . "REALLY-LONG-STRUCT-SLOT-NAME")))
+
+(deftest display.simple-struct.0
+ (labelled-element *simple-struct* 0)
+ " 0 FIRST ----------> the symbol NIL")
+(deftest display.simple-struct.1
+ (labelled-element *simple-struct* 1)
+ " 1 SLOT-2 ---------> the symbol A-VALUE")
+(deftest display.simple-struct.2
+ (labelled-element *simple-struct* 2)
+ " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
+
+(deftest display.simple-class.0
+ (labelled-element *simple-class* 0)
+ " 0 A --------------> ..unbound..")
+(deftest display.simple-class.1
+ (labelled-element *simple-class* 1)
+ " 1 SECOND ---------> fixnum 0")
+(deftest display.simple-class.2
+ (labelled-element *simple-class* 2)
+ " 2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"")
+
+(deftest display.complex.0
+ (labelled-element *complex* 0)
+ " 0 real -----------> fixnum 1")
+(deftest display.complex.1
+ (labelled-element *complex* 1)
+ " 1 imag -----------> fixnum 2")
+
+(deftest display.ratio.0
+ (labelled-element *ratio* 0)
+ " 0 numerator ------> fixnum 22")
+(deftest display.ratio.1
+ (labelled-element *ratio* 1)
+ " 1 denominator ----> fixnum 7")
+
+(deftest display.dotted-list.0
+ (labelled-element *dotted-list* 0)
+ " 0-> the symbol A")
+(deftest display.dotted-list.1
+ (labelled-element *dotted-list* 1)
+ " 1-> the symbol B")
+(deftest display.dotted-list.2
+ (labelled-element *dotted-list* 2)
+ "tail-> fixnum 3")
+
+(deftest display.normal-list.0
+ (labelled-element *normal-list* 0)
+ " 0-> the symbol A")
+(deftest display.normal-list.1
+ (labelled-element *normal-list* 1)
+ " 1-> the symbol B")
+(deftest display.normal-list.2
+ (labelled-element *normal-list* 2)
+ " 2-> fixnum 3")
+
+
+(deftest display.vector.0
+ (labelled-element *vector* 0)
+ " 0-> fixnum 0")
+(deftest display.vector.1
+ (labelled-element *vector* 1)
+ " 1-> fixnum 1")
+
+(deftest display.vector.skip1.0
+ (labelled-element *vector* 0 nil 2)
+ " ...")
+(deftest display.vector.skip1.1
+ (labelled-element *vector* 1 nil 2)
+ " 2-> fixnum 2")
+
+(deftest display.consp.0
+ (labelled-element *cons-pair* 0)
+ " 0 car ------------> complex number #C(1 2)")
+(deftest display.consp.1
+ (labelled-element *cons-pair* 1)
+ " 1 cdr ------------> the symbol A-SYMBOL")
+
+(do-tests)
+
+(when (pending-tests)
+ (error "Some tests failed."))
+
;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
;;;; variable.
-(cl:in-package :sb-aclrepl)
+(cl:in-package #:sb-aclrepl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +default-inspect-length+ 10))
;;; 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-"))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")))
;; Setup binding for multithreading
(list (format nil "(inspect ~S)" object)))
(%inspect output-stream))
-
+ (setq sb-impl::*inspect-fun* #'inspector)
+
+ (defun istep (args stream)
+ (unless *current-inspect*
+ (setq *current-inspect* (make-inspect)))
+ (istep-dispatch args
+ (first args)
+ (when (first args) (read-from-string (first args)))
+ stream))
+
+ (defun istep-dispatch (args option-string option stream)
+ (cond
+ ((or (string= "=" option-string) (zerop (length args)))
+ (istep-cmd-redisplay stream))
+ ((or (string= "-" option-string) (string= "^" option-string))
+ (istep-cmd-parent stream))
+ ((string= "*" option-string)
+ (istep-cmd-inspect-* stream))
+ ((string= "+" option-string)
+ (istep-cmd-inspect-new-form (read-from-string (second args)) stream))
+ ((or (string= "<" option-string)
+ (string= ">" option-string))
+ (istep-cmd-select-parent-component option-string stream))
+ ((string-equal "set" option-string)
+ (istep-cmd-set (second args) (third args) stream))
+ ((string-equal "raw" option-string)
+ (istep-cmd-set-raw (second args) stream))
+ ((string-equal "q" option-string)
+ (istep-cmd-reset))
+ ((string-equal "?" option-string)
+ (istep-cmd-help stream))
+ ((string-equal "skip" option-string)
+ (istep-cmd-skip (second args) stream))
+ ((string-equal "tree" option-string)
+ (istep-cmd-tree stream))
+ ((string-equal "print" option-string)
+ (istep-cmd-print (second args) stream))
+ ((or (symbolp option)
+ (integerp option))
+ (istep-cmd-select-component option stream))
+ (t
+ (istep-cmd-set-stack option stream))))
+
(defun set-current-inspect (inspect)
(setq *current-inspect* inspect))
- (defun istep (arg-string output-stream)
- (%istep arg-string output-stream))
-
- (setq sb-impl::*inspect-fun* #'inspector)
-
(defun reset-stack ()
(setf (inspect-object-stack *current-inspect*) nil)
(setf (inspect-select-stack *current-inspect*) nil))
- (defun %istep (arg-string output-stream)
- (unless *current-inspect*
- (setq *current-inspect* (make-inspect)))
- (let* ((args (when arg-string (string-to-list-skip-spaces arg-string)))
- (option (car args))
- (option-read (when arg-string
- (read-from-string arg-string)))
- (stack (inspect-object-stack *current-inspect*)))
+ (defun output-inspect-note (stream note &rest args)
+ (apply #'format stream note args)
+ (princ #\Newline stream))
+
+ (defun stack ()
+ (inspect-object-stack *current-inspect*))
+
+ (defun redisplay (stream)
+ (%inspect stream))
+
+ ;;;
+ ;;; istep command processing
+ ;;;
+
+ (defun istep-cmd-redisplay (stream)
+ (redisplay stream))
+
+ (defun istep-cmd-parent (stream)
+ (cond
+ ((> (length (inspect-object-stack *current-inspect*)) 1)
+ (setf (inspect-object-stack *current-inspect*)
+ (cdr (inspect-object-stack *current-inspect*)))
+ (setf (inspect-select-stack *current-inspect*)
+ (cdr (inspect-select-stack *current-inspect*)))
+ (redisplay stream))
+ ((stack)
+ (output-inspect-note stream "Object has no parent"))
+ (t
+ (redisplay stream))))
+
+ (defun istep-cmd-inspect-* (stream)
+ (reset-stack)
+ (setf (inspect-object-stack *current-inspect*) (list *))
+ (setf (inspect-select-stack *current-inspect*) (list "(inspect *)"))
+ (set-break-inspect *current-inspect*)
+ (redisplay stream))
+
+ (defun istep-cmd-inspect-new-form (form stream)
+ (inspector (eval form) nil stream))
+
+ (defun istep-cmd-select-parent-component (option stream)
+ (if (stack)
+ (if (eql (length (stack)) 1)
+ (output-inspect-note stream "Object does not have a parent")
+ (let ((parent (second (stack)))
+ (id (car (inspect-select-stack *current-inspect*))))
+ (multiple-value-bind (position parts)
+ (find-object-part-with-id parent id)
+ (let ((new-position (if (string= ">" option)
+ (1+ position)
+ (1- position))))
+ (if (< -1 new-position (parts-count parts))
+ (let* ((value (element-at parts new-position)))
+ (setf (car (inspect-object-stack *current-inspect*))
+ value)
+ (setf (car (inspect-select-stack *current-inspect*))
+ (if (integerp id)
+ new-position
+ (let ((label (label-at parts new-position)))
+ (if (stringp label)
+ (read-from-string label)
+ label))))
+ (redisplay stream))
+ (output-inspect-note stream
+ "Parent has no selectable component indexed by ~d"
+ new-position))))))
+ (redisplay stream)))
+
+ (defun istep-cmd-set-raw (option-string stream)
+ (when (inspect-object-stack *current-inspect*)
(cond
- ;; Redisplay
- ((or (string= "=" option)
- (zerop (length args)))
- (%inspect output-stream))
- ;; Select parent
- ((or (string= "-" option)
- (string= "^" option))
- (cond
- ((> (length stack) 1)
- (setf (inspect-object-stack *current-inspect*) (cdr stack))
- (setf (inspect-select-stack *current-inspect*)
- (cdr (inspect-select-stack *current-inspect*)))
- (%inspect output-stream))
- (stack
- (format output-stream "Object has no parent.~%"))
- (t
- (%inspect output-stream))))
- ;; Select * to inspect
- ((string= "*" option)
- (reset-stack)
- (setf (inspect-object-stack *current-inspect*) (list *))
- (setf (inspect-select-stack *current-inspect*) (list "(inspect *)"))
- (set-break-inspect *current-inspect*)
- (%inspect output-stream))
- ;; Start new inspect level for eval'd form
- ((string= "+" option)
- (inspector (eval (read-from-string (second args))) nil output-stream))
- ;; Next or previous parent component
- ((or (string= "<" option)
- (string= ">" option))
- (if stack
- (if (eq (length stack) 1)
- (format output-stream "Object does not have a parent")
- (let ((parent (second stack))
- (id (car (inspect-select-stack *current-inspect*))))
- (multiple-value-bind (position parts)
- (find-object-part-with-id parent id)
- (let ((new-position (if (string= ">" option)
- (1+ position)
- (1- position))))
- (if (< -1 new-position (parts-count parts))
- (let* ((value (element-at parts new-position)))
- (setf (car stack) value)
- (setf (car (inspect-select-stack *current-inspect*))
- (if (integerp id)
- new-position
- (let ((label (label-at parts new-position)))
- (if (stringp label)
- (read-from-string label)
- label))))
- (%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 stack
- (let ((id (when (second args)
- (read-from-string (second args)))))
- (multiple-value-bind (position parts)
- (find-object-part-with-id (car stack) id)
- (if parts
- (if position
- (let ((value-stirng (third args)))
- (when value-stirng
- (let ((new-value (eval (read-from-string (third args)))))
- (let ((result
- (set-component-value (car stack)
+ ((null option-string)
+ (setq *inspect-raw* t))
+ ((eq (read-from-string option-string) t)
+ (setq *inspect-raw* t))
+ ((eq (read-from-string option-string) nil)
+ (setq *inspect-raw* nil)))
+ (redisplay stream)))
+
+ (defun istep-cmd-reset ()
+ (reset-stack)
+ (set-break-inspect *current-inspect*))
+
+ (defun istep-cmd-help (stream)
+ (format stream *inspect-help*))
+
+ (defun istep-cmd-skip (option-string stream)
+ (if option-string
+ (let ((len (read-from-string option-string)))
+ (if (and (integerp len) (>= len 0))
+ (let ((*inspect-skip* len))
+ (redisplay stream))
+ (output-inspect-note stream "Skip length invalid")))
+ (output-inspect-note stream "Skip length missing")))
+
+ (defun istep-cmd-print (option-string stream)
+ (if option-string
+ (let ((len (read-from-string option-string)))
+ (if (and (integerp len) (plusp len))
+ (setq *inspect-length* len)
+ (output-inspect-note stream "Cannot set print limit to ~A~%" len)))
+ (output-inspect-note stream "Print length missing")))
+
+ (defun select-description (select)
+ (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))))
+
+ (defun istep-cmd-tree (stream)
+ (let ((stack (inspect-object-stack *current-inspect*)))
+ (if stack
+ (progn
+ (output-inspect-note stream "The current object is:")
+ (dotimes (i (length stack))
+ (output-inspect-note
+ stream "~A, ~A~%"
+ (inspected-description (nth i stack))
+ (select-description
+ (nth i (inspect-select-stack *current-inspect*))))))
+ (%inspect stream))))
+
+ (defun istep-cmd-set (id-string value-string stream)
+ (if (stack)
+ (let ((id (when id-string (read-from-string id-string))))
+ (multiple-value-bind (position parts)
+ (find-object-part-with-id (car (stack)) id)
+ (if parts
+ (if position
+ (when value-string
+ (let ((new-value (eval (read-from-string value-string))))
+ (let ((result (set-component-value (car (stack))
id
new-value
- (element-at parts position))))
- (typecase result
- (string
- (format output-stream result))
- (t
- (%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 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)
- (set-break-inspect *current-inspect*))
- ;; 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))
- (let ((*inspect-skip* len))
- (%inspect output-stream))
- (format output-stream "Skip missing or invalid~%"))))
- ;; Print stack tree
- ((string-equal "tree" option)
- (if stack
- (progn
- (format output-stream "The current object is:~%")
- (dotimes (i (length stack))
- (format output-stream "~A, ~A~%"
- (inspected-description (nth i stack))
- (let ((select (nth i (inspect-select-stack *current-inspect*))))
- (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 stack
- (multiple-value-bind (position parts)
- (find-object-part-with-id (car stack) option-read)
- (cond
- ((integerp position)
- (let* ((value (element-at parts position)))
- (cond ((eq value *inspect-unbound-object-marker*)
- (format output-stream "That slot is unbound~%"))
- (t
- (push value (inspect-object-stack *current-inspect*))
- (push option-read (inspect-select-stack *current-inspect*))
- (%inspect output-stream)))))
- ((null parts)
- (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
- (= (parts-count parts) 1)
- (1- (parts-count parts))))))))
- (%inspect output-stream)))
- ;; Default is to select eval'd form
- (t
- (reset-stack)
- (let ((object (eval option-read)))
- (setf (inspect-object-stack *current-inspect*) (list object))
- (setf (inspect-select-stack *current-inspect*)
- (list (format nil ":i ~S" object))))
- (set-break-inspect *current-inspect*)
- (%inspect output-stream))
- )))
-
- (defun %inspect (s)
- (if (inspect-object-stack *current-inspect*)
- (let ((inspected (car (inspect-object-stack *current-inspect*))))
- (setq cl:* inspected)
- (display-inspected-parts inspected s))
- (format s "No object is being inspected")))
-
-
- (defun display-inspected-parts (object stream)
- (multiple-value-bind (elements labels count)
- (inspected-elements object *inspect-length* *inspect-skip*)
- (format stream "~&~A" (inspected-description object))
- (unless (or (characterp object) (typep object 'fixnum))
- (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
- (princ #\newline stream)
- (dotimes (i count)
- (let ((label (elt labels i))
- (element (elt elements i)))
+ (element-at
+ parts position))))
+ (typecase result
+ (string
+ (output-inspect-note stream result))
+ (t
+ (%inspect stream))))))
+ (output-inspect-note
+ stream
+ "Object has no selectable component named by ~A" id))
+ (output-inspect-note stream
+ "Object has no selectable components"))))
+ (%inspect stream)))
+
+ (defun istep-cmd-select-component (id stream)
+ (if (stack)
+ (multiple-value-bind (position parts)
+ (find-object-part-with-id (car (stack)) id)
(cond
- ((eq label :ellipses)
- (format stream "~& ...~%"))
- ((eq label :tail)
- (format stream "tail-> ~A~%" (inspected-description element)))
- ((consp label)
- (format stream
- (if (and (stringp (cdr label)) (char= (char (cdr label) 0) #\[))
- ;; for arrays
- "~4,' D ~A-> ~A~%"
- ;; for named
- "~4,' D ~16,1,1,'-A> ~A~%")
- (car label)
- (format nil "~A " (cdr label))
- (if (eq element *inspect-unbound-object-marker*)
- "..unbound.."
- (inspected-description element))))
+ ((integerp position)
+ (let* ((value (element-at parts position)))
+ (cond ((eq value *inspect-unbound-object-marker*)
+ (output-inspect-note stream "That slot is unbound"))
+ (t
+ (push value (inspect-object-stack *current-inspect*))
+ (push id (inspect-select-stack *current-inspect*))
+ (redisplay stream)))))
+ ((null parts)
+ (output-inspect-note stream "Object does not contain any subobjects"))
(t
- (if (integerp label)
- (format stream "~4,' D-> ~A~%" label (inspected-description element))
- (format stream "~4A-> ~A~%" label (inspected-description element)))))))))
+ (typecase id
+ (symbol
+ (output-inspect-note
+ stream "Object has no selectable component named ~A"
+ id))
+ (integer
+ (output-inspect-note
+ stream "Object has no selectable component indexed by ~d"
+ id)
+ (output-inspect-note
+ stream "Enter a valid index (~:[0-~W~;0~])"
+ (= (parts-count parts) 1)
+ (1- (parts-count parts))))))))
+ (%inspect stream)))
+
+ (defun istep-cmd-set-stack (form stream)
+ (reset-stack)
+ (let ((object (eval form)))
+ (setf (inspect-object-stack *current-inspect*) (list object))
+ (setf (inspect-select-stack *current-inspect*)
+ (list (format nil ":i ~S" object))))
+ (set-break-inspect *current-inspect*)
+ (redisplay stream))
+
+ ;;;
+ ;;; aclrepl-specific inspection display
+ ;;;
+ (defun %inspect (s)
+ (if (inspect-object-stack *current-inspect*)
+ (let ((inspected))
+ (setq cl:* (car (inspect-object-stack *current-inspect*)))
+ (display-inspected-parts inspected s *inspect-length* *inspect-skip*))
+ (output-inspect-note s "No object is being inspected")))
) ;; end binding for multithreading
+(defun display-inspected-parts (object stream &optional length skip)
+ (multiple-value-bind (elements labels count)
+ (inspected-elements object length skip)
+ (format stream "~&~A" (inspected-description object))
+ (unless (or (characterp object) (typep object 'fixnum))
+ (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
+ (princ #\newline stream)
+ (dotimes (i count)
+ (fresh-line stream)
+ (display-labelled-element (elt elements i) (elt labels i) stream))))
+
+(defun array-label-p (label)
+ (and (stringp (cdr label)) (char= (char (cdr label) 0) #\[)))
+
+(defun named-or-array-label-p (label)
+ (consp label))
+
+(defun display-labelled-element (element label stream)
+ (cond
+ ((eq label :ellipses)
+ (format stream " ..."))
+ ((eq label :tail)
+ (format stream "tail-> ~A" (inspected-description element)))
+ ((named-or-array-label-p label)
+ (format stream
+ (if (array-label-p label)
+ "~4,' D ~A-> ~A"
+ "~4,' D ~16,1,1,'-A> ~A")
+ (car label)
+ (format nil "~A " (cdr label))
+ (inspected-description element)))
+ (t
+ (format stream "~4,' D-> ~A" label (inspected-description element)))))
+
;;; THE BEGINNINGS OF AN INSPECTOR API
;;; which can be used to retrieve object descriptions as component values/labels and also
-;;; process component length and skip selectors
+;;; process print length and skip selectors
;;;
;;; FUNCTIONS TO CONSIDER FOR EXPORT
;;; FIND-OBJECT-PART-WITH-ID
;;; INSPECTED-DESCRIPTION
;;;
;;; will also need hooks
-;;; *inspect-start-inspection* (maybe. Would setup a window for a GUI inspector)
+;;; *inspect-start-inspection*
+;;; (maybe. Would setup a window for a GUI inspector)
;;; *inspect-prompt-fun*
;;; *inspect-read-cmd*
;;;
;;; and, either an *inspect-process-cmd*, or *inspect-display* hook
;;; That'll depend if choose to have standardized inspector commands such that
;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will
-;;; process and then call the *inspect-display* hook, or if the *inspect-read-cmd*
-;;; will return an impl-dependent cmd that sbcl will send to the contributed
-;;; inspector for processing and display.
+;;; process and then call the *inspect-display* hook, or if the
+;;; *inspect-read-cmd* will return an impl-dependent cmd that sbcl will
+;;; send to the contributed inspector for processing and display.
(defun find-object-part-with-id (object id)
"COMPONENT-ID can be an integer or a name of a id.
(push r list)))
(format nil "[~W~{,~W~}]" (car list) (cdr list))))))
-(defun inspected-elements (object length skip)
+(defun inspected-elements (object &optional length skip)
"Returns elements of an object that have been trimmed and labeled based on
-length and skip. Returns (VALUES ELEMENTS LABELS COUNT) where ELEMENTS contains
-COUNT ITERMS, LABELS is a SEQUENCES with COUNT items. LABELS may be a string, number,
-:tail, or :ellipses. This function may return a COUNT of up to (+ 3 length) which would
-include an :ellipses at the beginning, :ellipses at the end, and the last element."
+length and skip. Returns (VALUES ELEMENTS LABELS ELEMENT-COUNT)
+where ELEMENTS and LABELS are vectors containing ELEMENT-COUNT items.
+LABELS may be a string, number, cons pair, :tail, or :ellipses.
+This function may return an ELEMENT-COUNT of up to (+ 3 length) which would
+include an :ellipses at the beginning, :ellipses at the end,
+and the last element."
(let* ((parts (inspected-parts object))
(count (parts-count parts)))
(unless skip (setq skip 0))
(defmethod inspected-description ((object t))
(format nil "a generic object ~W" object))
+(defmethod inspected-description ((object (eql *inspect-unbound-object-marker*)))
+ "..unbound..")
+
\f
;;; INSPECTED-PARTS
;;;
;;; If SEQ-TYPE is :list, then each element is a value of an array
;;; If SEQ-TYPE is :vector, then each element is a value of an vector
;;; If SEQ-TYPE is :array, then each element is a value of an array
-;;; with rank >= 2
+;;; with rank >= 2. The
;;;
;;; COUNT is the total number of components in the OBJECT
;;;
-;;; SEQ-HINT Stores a seq-type dependent hint. Used by SEQ-TYPE :array
+;;; SEQ-HINT is a seq-type dependent hint. Used by SEQ-TYPE :array
;;; to hold the reverse-dimensions of the orignal array.
(declaim (inline parts-components))
(defun inspected-standard-object-parts (object)
(let ((reversed-components nil)
(class-slots (sb-pcl::class-slots (class-of object))))
- (dolist (class-slot class-slots (nreverse reversed-components))
+ (dolist (class-slot class-slots reversed-components)
(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-components)))))
+
(defmethod inspected-parts ((object standard-object))
(let ((components (inspected-standard-object-parts object)))
(list components (length components) :named nil)))
(defmethod set-component-value ((object standard-object) id value element)
(format nil "Standard object does not support setting of component ~A" id))
-(defmethod set-component-value ((object sb-kernel:funcallable-instance) id value element)
- (format nil "Funcallable instance object does not support setting of component ~A" id))
-
-(defmethod set-component-value ((object function) id value element)
- (format nil "Function object does not support setting of component ~A" id))
-
-;; whn believes it is unsafe to change components of this object
-(defmethod set-component-value ((object complex) id value element)
- (format nil "Object does not support setting of component ~A" id))
-
-;; whn believes it is unsafe to change components of this object
-(defmethod set-component-value ((object ratio) id value element)
- (format nil "Object does not support setting of component ~A" id))
-
(defmethod set-component-value ((object t) id value element)
(format nil "Object does not support setting of component ~A" id))
--- /dev/null
+;-*- Mode: Lisp -*-
+;;;; Paul Dietz's version of rt from ansi-tests
+
+(defpackage :regression-test
+ (:use #:cl)
+ (:nicknames :rtest #-lispworks :rt)
+ (:export
+ #:*do-tests-when-defined*
+ #:*test*
+ #:continue-testing
+ #:deftest
+ #:do-test
+ #:do-tests
+ #:get-test
+ #:pending-tests
+ #:rem-all-tests
+ #:rem-test
+ ))
+
+(in-package :regression-test)
+;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
+
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ | |
+ | Permission to use, copy, modify, and distribute this software and its |
+ | documentation for any purpose and without fee is hereby granted, provided |
+ | that this copyright and permission notice appear in all copies and |
+ | supporting documentation, and that the name of M.I.T. not be used in |
+ | advertising or publicity pertaining to distribution of the software |
+ | without specific, written prior permission. M.I.T. makes no |
+ | representations about the suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty. |
+ | |
+ | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
+ | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
+ | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
+ | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
+ | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
+ | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
+ | SOFTWARE. |
+ |----------------------------------------------------------------------------|#
+
+;This is the December 19, 1990 version of the regression tester.
+
+(in-package :regression-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+ "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+
+(defvar *compile-tests* nil "When true, compile the tests before running
+them.")
+(defvar *optimization-settings* '((safety 3)))
+
+(defvar *expected-failures* nil
+ "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+ (:type list))
+ pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+ (do ((l (cdr *entries*) (cdr l))
+ (r nil))
+ ((null l) (nreverse r))
+ (when (pend (car l))
+ (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+ (setq *entries* (list nil))
+ nil)
+
+(defun rem-test (&optional (name *test*))
+ (do ((l *entries* (cdr l)))
+ ((null (cdr l)) nil)
+ (when (equal (name (cadr l)) name)
+ (setf (cdr l) (cddr l))
+ (return name))))
+
+(defun get-test (&optional (name *test*))
+ (defn (get-entry name)))
+
+(defun get-entry (name)
+ (let ((entry (find name (cdr *entries*)
+ :key #'name
+ :test #'equal)))
+ (when (null entry)
+ (report-error t
+ "~%No test with name ~:@(~S~)."
+ name))
+ entry))
+
+(defmacro deftest (name form &rest values)
+ `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+ (setq entry (copy-list entry))
+ (do ((l *entries* (cdr l))) (nil)
+ (when (null (cdr l))
+ (setf (cdr l) (list entry))
+ (return nil))
+ (when (equal (name (cadr l))
+ (name entry))
+ (setf (cadr l) entry)
+ (report-error nil
+ "Redefining test ~:@(~S~)"
+ (name entry))
+ (return nil)))
+ (when *do-tests-when-defined*
+ (do-entry entry))
+ (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+ (cond (*debug*
+ (apply #'format t args)
+ (if error? (throw '*debug* nil)))
+ (error? (apply #'error args))
+ (t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+ (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+ "Like EQUALP, but doesn't do case conversion of characters.
+ Currently doesn't work on arrays of dimension > 2."
+ (cond
+ ((consp x)
+ (and (consp y)
+ (equalp-with-case (car x) (car y))
+ (equalp-with-case (cdr x) (cdr y))))
+ ((and (typep x 'array)
+ (= (array-rank x) 0))
+ (equalp-with-case (aref x) (aref y)))
+ ((typep x 'vector)
+ (and (typep y 'vector)
+ (let ((x-len (length x))
+ (y-len (length y)))
+ (and (eql x-len y-len)
+ (loop
+ for e1 across x
+ for e2 across y
+ always (equalp-with-case e1 e2))))))
+ ((and (typep x 'array)
+ (typep y 'array)
+ (not (equal (array-dimensions x)
+ (array-dimensions y))))
+ nil)
+ #|
+ ((and (typep x 'array)
+ (= (array-rank x) 2))
+ (let ((dim (array-dimensions x)))
+ (loop for i from 0 below (first dim)
+ always (loop for j from 0 below (second dim)
+ always (equalp-with-case (aref x i j)
+ (aref y i j))))))
+ |#
+
+ ((typep x 'array)
+ (and (typep y 'array)
+ (let ((size (array-total-size x)))
+ (loop for i from 0 below size
+ always (equalp-with-case (row-major-aref x i)
+ (row-major-aref y i))))))
+
+ (t (eql x y))))
+
+(defun do-entry (entry &optional
+ (s *standard-output*))
+ (catch '*in-test*
+ (setq *test* (name entry))
+ (setf (pend entry) t)
+ (let* ((*in-test* t)
+ ;; (*break-on-warnings* t)
+ (aborted nil)
+ r)
+ ;; (declare (special *break-on-warnings*))
+
+ (block aborted
+ (setf r
+ (flet ((%do
+ ()
+ (if *compile-tests*
+ (multiple-value-list
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare
+ (optimize ,@*optimization-settings*))
+ ,(form entry)))))
+ (multiple-value-list
+ (eval (form entry))))))
+ (if *catch-errors*
+ (handler-bind
+ (#-ecl (style-warning #'muffle-warning)
+ (error #'(lambda (c)
+ (setf aborted t)
+ (setf r (list c))
+ (return-from aborted nil))))
+ (%do))
+ (%do)))))
+
+ (setf (pend entry)
+ (or aborted
+ (not (equalp-with-case r (vals entry)))))
+
+ (when (pend entry)
+ (let ((*print-circle* *print-circle-on-failure*))
+ (format s "~&Test ~:@(~S~) failed~
+ ~%Form: ~S~
+ ~%Expected value~P: ~
+ ~{~S~^~%~17t~}~%"
+ *test* (form entry)
+ (length (vals entry))
+ (vals entry))
+ (format s "Actual value~P: ~
+ ~{~S~^~%~15t~}.~%"
+ (length r) r)))))
+ (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+ (if *in-test*
+ (throw '*in-test* nil)
+ (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+ (out *standard-output*))
+ (dolist (entry (cdr *entries*))
+ (setf (pend entry) t))
+ (if (streamp out)
+ (do-entries out)
+ (with-open-file
+ (stream out :direction :output)
+ (do-entries stream))))
+
+(defun do-entries (s)
+ (format s "~&Doing ~A pending test~:P ~
+ of ~A tests total.~%"
+ (count t (cdr *entries*)
+ :key #'pend)
+ (length (cdr *entries*)))
+ (dolist (entry (cdr *entries*))
+ (when (pend entry)
+ (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+ (do-entry entry s))))
+ (let ((pending (pending-tests))
+ (expected-table (make-hash-table :test #'equal)))
+ (dolist (ex *expected-failures*)
+ (setf (gethash ex expected-table) t))
+ (let ((new-failures
+ (loop for pend in pending
+ unless (gethash pend expected-table)
+ collect pend)))
+ (if (null pending)
+ (format s "~&No tests failed.")
+ (progn
+ (format s "~&~A out of ~A ~
+ total tests failed: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length pending)
+ (length (cdr *entries*))
+ pending)
+ (if (null new-failures)
+ (format s "~&No unexpected failures.")
+ (when *expected-failures*
+ (format s "~&~A unexpected failures: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length new-failures)
+ new-failures)))
+ ))
+ (null pending))))
projects / sbcl.git / commitdiff