(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
+(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-part-id
- sb-aclrepl::element-at sb-aclrepl::label-at
+ sb-aclrepl::component-at sb-aclrepl::label-at
sb-aclrepl::reset-cmd
sb-aclrepl::inspector
sb-aclrepl::display-inspect
(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)))
+(defparameter *circle-list1* '(a))
+(setf (car *circle-list1*) *circle-list1*)
+(defparameter *circle-list2* '(b))
+(setf (cdr *circle-list2*) *circle-list2*)
+(defparameter *circle-list3* '(a b c))
+(setf (car *circle-list3*) *circle-list3*)
+(defparameter *circle-list4* '(a b c))
+(setf (second *circle-list4*) *circle-list4*)
+(defparameter *circle-list5* '(a b c))
+(setf (cddr *circle-list5*) *circle-list5*)
(defun find-position (object id)
(nth-value 0 (find-part-id object id)))
(defun parts (object)
- (inspected-parts object))
+ (let ((*skip-address-display* t))
+ (inspected-parts object)))
(defun description (object)
- (inspected-description object))
+ (let ((*skip-address-display* t))
+ (inspected-description object)))
(defun elements (object &optional print (skip 0))
- (nth-value 0 (inspected-elements object print skip )))
+ (let ((*skip-address-display* t))
+ (inspected-elements object print skip)))
+(defun elements-components (object &optional print (skip 0))
+ (nth-value 0 (elements object print skip )))
(defun elements-labels (object &optional print (skip 0))
- (nth-value 1 (inspected-elements object print skip)))
+ (nth-value 1 (elements object print skip)))
(defun elements-count (object &optional print (skip 0))
- (nth-value 2 (inspected-elements object print skip)))
+ (nth-value 2 (elements object print skip)))
(defun labeled-element (object pos &optional print (skip 0))
(with-output-to-string (strm)
- (display-labeled-element
- (aref (the simple-vector (elements object print skip)) pos)
- (aref (the simple-vector (elements-labels object print skip)) pos)
- strm)))
+ (let ((*skip-address-display* t))
+ (display-labeled-element
+ (aref (the simple-vector (elements-components object print skip)) pos)
+ (aref (the simple-vector (elements-labels object print skip)) pos)
+ strm))))
(defun display (object &optional print (skip 0))
(with-output-to-string (strm)
(let ((*skip-address-display* t))
(display-inspect object strm print skip))))
-(defun inspect (object)
+(defun do-inspect (object)
(with-output-to-string (strm)
(let ((*skip-address-display* t))
(inspector `(quote ,object) nil strm))))
(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.2 (component-at (parts *normal-list*) 0) a)
+(deftest parts.list.3 (component-at (parts *normal-list*) 1) b)
+(deftest parts.list.4 (component-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*)
+(defun basename (id &optional print (skip 0))
+ (let ((name (typecase id
+ (symbol (symbol-name id))
+ (string (string-upcase id))
+ (t (format nil "~A" id)))))
+ (format nil "~A~A~A"
+ (string-left-trim "*" (string-right-trim "*" name))
+ (if print (format nil ".P~D" print) "")
+ (if (not (zerop skip)) (format nil ".S~D" skip) ""))))
+
+(defun elements-tests-name (id ext print skip)
+ (intern (format nil "ELEM.~A.~A" (basename id print skip) ext)))
+
+(defmacro def-elements-tests (object count components labels
+ &optional (print nil) (skip 0))
+ `(progn
+ (deftest ,(elements-tests-name object "COUNT" print skip)
+ (elements-count ,object ,print ,skip) ,count)
+ (unless (eq ,components :dont-check)
+ (deftest ,(elements-tests-name object "COMPONENTS" print skip)
+ (elements-components ,object ,print ,skip) ,components))
+ (deftest ,(elements-tests-name object "LABELS" print skip)
+ (elements-labels ,object ,print ,skip) ,labels)))
+
+(def-elements-tests *normal-list* 3 #(a b 3) #(0 1 2))
+(def-elements-tests *dotted-list* 3 #(a b 3) #(0 1 :tail))
+
+(def-elements-tests *circle-list1* 2 :dont-check #((0 . "car") (1 . "cdr")))
+(def-elements-tests *circle-list2* 2 :dont-check #(0 :tail))
+(def-elements-tests *circle-list3* 3 :dont-check #(0 1 2))
+(def-elements-tests *circle-list4* 3 :dont-check #(0 1 2))
+(def-elements-tests *circle-list5* 3 :dont-check #(0 1 :tail))
+
+(deftest circle-list1-components
+ (equalp (aref (elements-components *circle-list1*) 0) *circle-list1*) t)
+(deftest circle-list2-components.0
+ (equalp (aref (elements-components *circle-list2*) 0) 'b) t)
+(deftest circle-list2-components.1
+ (equalp (aref (elements-components *circle-list2*) 1) *circle-list2*) t)
+(deftest circle-list3-components.0
+ (equalp (aref (elements-components *circle-list3*) 0) *circle-list3*) t)
+(deftest circle-list3-components.1
+ (equalp (aref (elements-components *circle-list3*) 1) 'b) t)
+(deftest circle-list3-components.2
+ (equalp (aref (elements-components *circle-list3*) 2) 'c) t)
+(deftest circle-list4-components.0
+ (equalp (aref (elements-components *circle-list4*) 0) 'a) t)
+(deftest circle-list4-components.1
+ (equalp (aref (elements-components *circle-list4*) 1) *circle-list4*) t)
+(deftest circle-list4-components.2
+ (equalp (aref (elements-components *circle-list4*) 2) 'c) t)
+(deftest circle-list5-components.0
+ (equalp (aref (elements-components *circle-list5*) 0) 'a) t)
+(deftest circle-list5-components.1
+ (equalp (aref (elements-components *circle-list5*) 1) 'b) t)
+(deftest circle-list5-components.2
+ (equalp (aref (elements-components *circle-list5*) 2) *circle-list5*) t)
+
+(def-elements-tests *cons-pair* 2 #(#c(1 2) a-symbol)
+ #((0 . "car") (1 . "cdr")))
+(def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag")))
+(def-elements-tests *ratio* 2 #(22 7)
+ #((0 . "numerator") (1 . "denominator")))
+(def-elements-tests *vector* 20
+ #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
+ #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
+(def-elements-tests *vector* 18
+ #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
+ #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
+ nil 3)
+(def-elements-tests *vector* 13
+ #(nil 3 4 5 6 7 8 9 10 11 12 nil 19)
+ #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19)
+ 10 3)
+(def-elements-tests *vector* 5
+ #(nil 16 17 18 19)
+ #(:ellipses 16 17 18 19)
+ 5 16)
+(def-elements-tests *vector* 5
+ #(nil 16 17 18 19)
+ #(:ellipses 16 17 18 19)
+ 2 16)
+(def-elements-tests *vector* 5
+ #(nil 15 16 nil 19)
+ #(:ellipses 15 16 :ellipses 19)
+ 2 15)
+(def-elements-tests *array* 18
#(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*)
+ NIL NIL)
#((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]")
(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*)
+(def-elements-tests *empty-class* 0 nil nil)
+(def-elements-tests *simple-class* 3
+ #(#.*inspect-unbound-object-marker* 0 "abc")
#((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*)
+(def-elements-tests *empty-struct* 0 nil nil)
+(def-elements-tests *simple-struct* 3
+ #(nil a-value "defg")
#((0 . "FIRST") (1 . "SLOT-2")
(2 . "REALLY-LONG-STRUCT-SLOT-NAME")))
-(deftest label.simple-struct.0 (labeled-element *simple-struct* 0)
+(defun label-test-name (name pos &optional print (skip 0))
+ (intern (format nil "LABEL.~A.~D" (basename name print skip) pos)))
+
+(defmacro def-label-test (object pos label &optional print (skip 0))
+ `(deftest ,(label-test-name object pos print skip)
+ (labeled-element ,object ,pos ,print ,skip) ,label))
+
+(def-label-test *simple-struct* 0
" 0 FIRST ----------> the symbol NIL")
-(deftest label.simple-struct.1 (labeled-element *simple-struct* 1)
+(def-label-test *simple-struct* 1
" 1 SLOT-2 ---------> the symbol A-VALUE")
-(deftest label.simple-struct.2 (labeled-element *simple-struct* 2)
- " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
-
-(deftest label.simple-class.0 (labeled-element *simple-class* 0)
+(def-label-test *simple-struct* 2
+ " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
+(def-label-test *simple-class* 0
" 0 A --------------> ..unbound..")
-(deftest label.simple-class.1 (labeled-element *simple-class* 1)
+(def-label-test *simple-class* 1
" 1 SECOND ---------> fixnum 0")
-(deftest label.simple-class.2 (labeled-element *simple-class* 2)
+(def-label-test *simple-class* 2
" 2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"")
-(deftest label.complex.0 (labeled-element *complex* 0)
- " 0 real -----------> fixnum 1")
-(deftest label.complex.1 (labeled-element *complex* 1)
- " 1 imag -----------> fixnum 2")
-
-(deftest label.ratio.0 (labeled-element *ratio* 0)
- " 0 numerator ------> fixnum 22")
-(deftest label.ratio.1 (labeled-element *ratio* 1)
- " 1 denominator ----> fixnum 7")
-
-(deftest label.dotted-list.0 (labeled-element *dotted-list* 0)
- " 0-> the symbol A")
-(deftest label.dotted-list.1 (labeled-element *dotted-list* 1)
- " 1-> the symbol B")
-(deftest label.dotted-list.2 (labeled-element *dotted-list* 2)
- "tail-> fixnum 3")
-
-(deftest label.normal-list.0
- (labeled-element *normal-list* 0)
- " 0-> the symbol A")
-(deftest label.normal-list.1 (labeled-element *normal-list* 1)
- " 1-> the symbol B")
-(deftest label.normal-list.2 (labeled-element *normal-list* 2)
- " 2-> fixnum 3")
-
-
-(deftest label.vector.0 (labeled-element *vector* 0)
- " 0-> fixnum 0")
-(deftest label.vector.1 (labeled-element *vector* 1)
- " 1-> fixnum 1")
-
-(deftest label.vector.skip1.0 (labeled-element *vector* 0 nil 2)
- " ...")
-(deftest label.vector.skip1.1 (labeled-element *vector* 1 nil 2)
- " 2-> fixnum 2")
-
-(deftest label.consp.0 (labeled-element *cons-pair* 0)
- " 0 car ------------> complex number #C(1 2)")
-(deftest label.consp.1 (labeled-element *cons-pair* 1)
+(def-label-test *complex* 0 " 0 real -----------> fixnum 1")
+(def-label-test *complex* 1 " 1 imag -----------> fixnum 2")
+
+(def-label-test *ratio* 0 " 0 numerator ------> fixnum 22")
+(def-label-test *ratio* 1 " 1 denominator ----> fixnum 7")
+
+(def-label-test *dotted-list* 0 " 0-> the symbol A")
+(def-label-test *dotted-list* 1 " 1-> the symbol B")
+(def-label-test *dotted-list* 2 "tail-> fixnum 3")
+
+(def-label-test *normal-list* 0 " 0-> the symbol A")
+(def-label-test *normal-list* 1 " 1-> the symbol B")
+(def-label-test *normal-list* 2 " 2-> fixnum 3")
+
+(def-label-test *vector* 0 " 0-> fixnum 0")
+(def-label-test *vector* 1 " 1-> fixnum 1")
+(def-label-test *vector* 0 " ..." nil 2)
+(def-label-test *vector* 1" 2-> fixnum 2" nil 2)
+
+(def-label-test *cons-pair* 0
+ " 0 car ------------> complex number #C(1 2)")
+(def-label-test *cons-pair* 1
" 1 cdr ------------> the symbol A-SYMBOL")
(deftest nil.parts.0 (elements-count nil) 5)
-(deftest tiny.struct.0 (elements-count *tiny-struct*) 1)
-(deftest tiny.struct.1 (elements *tiny-struct*) #(10))
-(deftest tiny.struct.2 (elements-labels *tiny-struct*) #((0 . "FIRST")))
+(def-elements-tests *tiny-struct* 1 #(10) #((0 . "FIRST")))
+(def-elements-tests *tiny-struct* 1
+ #(nil) #(:ellipses) nil 1)
+(def-elements-tests *tiny-struct* 1
+ #(nil) #(:ellipses) nil 2)
-(deftest tiny.struct.skip1.0 (elements-count *tiny-struct* nil 1) 1)
-(deftest tiny.struct.skip1.1 (elements *tiny-struct* nil 1)
- #(nil))
-(deftest tiny.struct.skip1.2 (elements-labels *tiny-struct* nil 1)
- #(:ellipses))
+(def-elements-tests *double* 0 nil nil)
+(def-elements-tests *double* 0 nil nil nil 1)
-(deftest tiny.double.0 (elements-count *double*) 0)
+(defun display-test-name (name print skip)
+ (intern (format nil "DISPLAY.~A" (basename name print skip))))
-(deftest tiny.double.skip1.0 (elements-count *double* nil 1) 0)
-(deftest tiny.double.skip1.1 (elements *double* nil 0)
- nil)
-(deftest tiny.doubel.skip1.2 (elements-labels *double* nil 1)
- nil)
+(defmacro def-display-test (object string &optional print (skip 0))
+ `(deftest ,(display-test-name object print skip)
+ (display ,object ,print ,skip) ,string))
-(deftest display.consp.0 (display *cons-pair*)
+(def-display-test *cons-pair*
"a cons cell
0 car ------------> complex number #C(1 2)
1 cdr ------------> the symbol A-SYMBOL")
-(deftest display.struct.0 (display *simple-struct*)
+(def-display-test *simple-struct*
"#<STRUCTURE-CLASS SIMPLE-STRUCT>
0 FIRST ----------> the symbol NIL
1 SLOT-2 ---------> the symbol A-VALUE
2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
-(deftest display.struct.1 (display *simple-struct* nil 2 )
+(def-display-test *simple-struct*
"#<STRUCTURE-CLASS SIMPLE-STRUCT>
...
- 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
+ 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\""
+ nil 2)
-(deftest display.vector.0 (display *vector* 5 6)
+(def-display-test *vector*
"a simple T vector (20)
...
6-> fixnum 6
9-> fixnum 9
10-> fixnum 10
...
- 19-> fixnum 19")
-
-#+ignore
-(deftest inspect.0 (prog1 (inspect *simple-struct*))
+ 19-> fixnum 19"
+ 5 6)
+
+(def-display-test *circle-list1*
+"a cons cell
+ 0 car ------------> a cons cell
+ 1 cdr ------------> the symbol NIL")
+(def-display-test *circle-list2*
+"a cyclic list with 1 element+tail
+ 0-> the symbol B
+tail-> a cyclic list with 1 element+tail")
+(def-display-test *circle-list3*
+"a normal list with 3 elements
+ 0-> a normal list with 3 elements
+ 1-> the symbol B
+ 2-> the symbol C")
+(def-display-test *circle-list4*
+"a normal list with 3 elements
+ 0-> the symbol A
+ 1-> a normal list with 3 elements
+ 2-> the symbol C")
+(def-display-test *circle-list5*
+ "a cyclic list with 2 elements+tail
+ 0-> the symbol A
+ 1-> the symbol B
+tail-> a cyclic list with 2 elements+tail")
+
+
+;;; Inspector traversal tests
+
+(deftest inspect.0 (prog1 (do-inspect *simple-struct*))
"#<STRUCTURE-CLASS SIMPLE-STRUCT>
0 FIRST ----------> the symbol NIL
1 SLOT-2 ---------> the symbol A-VALUE
2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
(deftest istep.0 (prog1
- (progn (inspect *simple-struct*) (istep '("=")))
+ (progn (do-inspect *simple-struct*) (istep '("=")))
(reset-cmd))
"#<STRUCTURE-CLASS SIMPLE-STRUCT>
0 FIRST ----------> the symbol NIL
2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
(deftest istep.1 (prog1
- (progn (inspect *simple-struct*) (istep '("first")))
+ (progn (do-inspect *simple-struct*) (istep '("first")))
(reset-cmd))
"the symbol NIL
0 NAME -----------> a simple-string (3) \"NIL\"
4 PLIST ----------> the symbol NIL")
(deftest istep.2 (prog1
- (progn (inspect *simple-struct*) (istep '("first"))
+ (progn (do-inspect *simple-struct*) (istep '("first"))
(istep '(">")))
(reset-cmd))
"the symbol A-VALUE
4 PLIST ----------> the symbol NIL")
(deftest istep.3 (prog1
- (progn (inspect *simple-struct*) (istep '("first"))
+ (progn (do-inspect *simple-struct*) (istep '("first"))
(istep '(">")) (istep '("<")))
(reset-cmd))
"the symbol NIL
4 PLIST ----------> the symbol NIL")
(deftest istep.4 (prog1
- (progn (inspect *simple-struct*) (istep '("first"))
+ (progn (do-inspect *simple-struct*) (istep '("first"))
(istep '(">")) (istep '("<")) (istep '("tree")))
(reset-cmd))
"The current object is:
")
(deftest istep.5 (prog1
- (progn (inspect *simple-struct*) (istep '("first"))
+ (progn (do-inspect *simple-struct*) (istep '("first"))
(istep '(">")) (istep '("<")) (istep '("-")))
(reset-cmd))
"#<STRUCTURE-CLASS SIMPLE-STRUCT>
2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
(deftest istep.6 (prog1
- (progn (inspect *dotted-list*) (istep '("tail")))
+ (progn (do-inspect *dotted-list*) (istep '("tail")))
(reset-cmd))
"fixnum 3")
(deftest istep.7 (prog1
- (progn (inspect *dotted-list*) (istep '("2")))
+ (progn (do-inspect *dotted-list*) (istep '("2")))
(reset-cmd))
"fixnum 3")
(do-tests)
-(when (pending-tests)
- (error "Some tests failed."))
+;(when (pending-tests)
+; (error "Some tests failed."))
(1+ position)
(1- position))))
(if (< -1 new-position (parts-count parts))
- (let* ((value (element-at parts new-position)))
+ (let* ((value (component-at parts new-position)))
(setf (car (inspect-object-stack *current-inspect*))
value)
(setf (car (inspect-select-stack *current-inspect*))
(let ((result (set-component-value (car (stack))
id
new-value
- (element-at
+ (component-at
parts position))))
(typecase result
(string
(find-part-id (car (stack)) id)
(cond
((integerp position)
- (let* ((value (element-at parts position)))
+ (let* ((value (component-at parts position)))
(cond ((eq value *inspect-unbound-object-marker*)
(output-inspect-note stream "That slot is unbound"))
(t
;;;
;;; FUNCTIONS TO CONSIDER FOR EXPORT
;;; FIND-PART-ID
-;;; ELEMENT-AT
+;;; COMPONENT-AT
;;; ID-AT
;;; INSPECTED-ELEMENTS
;;; INSPECTED-DESCRIPTION
(:named
(position name (the list (parts-components parts))
:key #'car :test #'string-equal))
- (:improper-list
+ ((:dotted-list :cyclic-list)
(when (string-equal name "tail")
(1- (parts-count parts))))))
parts)))
-(defun element-at (parts position)
+(defun component-at (parts position)
(let ((count (parts-count parts))
(components (parts-components parts)))
(when (< -1 position count)
(case (parts-seq-type parts)
- (:improper-list
+ (:dotted-list
(if (= position (1- count))
(cdr (last components))
(elt components position)))
+ (:cyclic-list
+ (if (= position (1- count))
+ components
+ (elt components position)))
(:named
(cdr (elt components position)))
(:array
(let ((count (parts-count parts)))
(when (< -1 position count)
(case (parts-seq-type parts)
- (:improper-list
+ ((:dotted-list :cyclic-list)
(if (= position (1- count))
:tail
position))
element-count))
(defun set-element (elements labels parts to-index from-index)
- (set-element-values elements labels to-index (element-at parts from-index)
+ (set-element-values elements labels to-index (component-at parts from-index)
(label-at parts from-index)))
(defun set-element-values (elements labels index element label)
"a cons cell"
(inspected-description-of-nontrivial-list object)))
-(defun dotted-safe-length (object)
- "Returns (VALUES LENGTH PROPER-P) where length is the number of cons cells"
- (do ((length 0 (1+ length))
- (lst object (cdr lst)))
- ((not (consp lst))
- (if (null lst)
- (values length t)
- (values length nil)))
+(defun cons-safe-length (object)
+ "Returns (VALUES LENGTH LIST-TYPE) where length is the number of
+cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
+ (do ((length 1 (1+ length))
+ (lst (cdr object) (cdr lst)))
+ ((or (not(consp lst))
+ (eq object lst))
+ (cond
+ ((null lst)
+ (values length :normal))
+ ((atom lst)
+ (values length :dotted))
+ ((eq object lst)
+ (values length :cyclic))))
;; nothing to do in body
))
(defun inspected-description-of-nontrivial-list (object)
- (multiple-value-bind (length proper-p) (dotted-safe-length object)
- (if proper-p
- (format nil "a proper list with ~D element~:*~P" length)
- (format nil "a dotted list with ~D element~:*~P + tail" length))))
+ (multiple-value-bind (length list-type) (cons-safe-length object)
+ (format nil "a ~A list with ~D element~:*~P~A"
+ (string-downcase (symbol-name list-type)) length
+ (case list-type
+ ((:dotted :cyclic) "+tail")
+ (t "")))))
(defmethod inspected-description ((object double-float))
(format nil "double-float ~W" object))
(format nil "single-float ~W" object))
(defmethod inspected-description ((object fixnum))
- (format nil "fixnum ~W" object))
+ (format nil "fixnum ~W~A" object
+ (if *skip-address-display*
+ ""
+ (format nil " [#x~8,'0X]" object
+ (sb-kernel:get-lisp-obj-address object)))))
(defmethod inspected-description ((object complex))
(format nil "complex number ~W" object))
(format nil "ratio ~W" object))
(defmethod inspected-description ((object character))
- (format nil "character ~W char-code #x~X" object (char-code object)))
+ (format nil "character ~W char-code~A" object (char-code object)
+ (if *skip-address-display*
+ ""
+ (format nil " [#x~8,'0X]" object
+ (sb-kernel:get-lisp-obj-address object)))))
(defmethod inspected-description ((object t))
(format nil "a generic object ~W" object))
;;; SEQ-TYPE determines what representation is used for components
;;; of COMPONENTS.
;;; If SEQ-TYPE is :named, then each element is (CONS NAME VALUE)
-;;; If SEQ-TYPE is :improper-list, then each element is just value,
+;;; If SEQ-TYPE is :dotted-list, then each element is just value,
;;; but the last element must be retrieved by
;;; (cdr (last components))
+;;; If SEQ-TYPE is :cylic-list, then each element is just value,
;;; 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
(list components 2 :named nil)))
(defun inspected-parts-of-nontrivial-list (object)
- (multiple-value-bind (count proper-p) (dotted-safe-length object)
- (if proper-p
- (list object count :list nil)
- ;; count tail element
- (list object (1+ count) :improper-list nil))))
+ (multiple-value-bind (count list-type) (cons-safe-length object)
+ (case list-type
+ (:normal
+ (list object count :list nil))
+ (:cyclic
+ (list object (1+ count) :cyclic-list nil))
+ (:dotted
+ ;; count tail element
+ (list object (1+ count) :dotted-list nil)))))
(defmethod inspected-parts ((object complex))
(let ((components (list (cons "real" (realpart object))
projects / sbcl.git / commitdiff