1 ;; Tests for sb-aclrepl
3 (defpackage #:aclrepl-tests
4 (:use #:sb-aclrepl #:cl #:sb-rt))
5 (in-package #:aclrepl-tests)
7 (declaim (special sb-aclrepl::*skip-address-display*
8 sb-aclrepl::*inspect-unbound-object-marker*))
10 (setf sb-rt::*catch-errors* nil)
14 (deftest hook.1 (boundp 'sb-impl::*inspect-fun*) t)
15 (deftest hook.2 (boundp 'sb-int:*repl-prompt-fun*) t)
16 (deftest hook.3 (boundp 'sb-int:*repl-read-form-fun*) t)
17 ;(deftest (boundp 'sb-debug::*invoke-debugger-fun*) t)
21 (defclass empty-class ()
23 (defparameter *empty-class* (make-instance 'empty-class))
25 (defclass empty-class ()
28 (defclass simple-class ()
31 (really-long-slot-name :initform "abc")))
33 (defstruct empty-struct
36 (defstruct tiny-struct
39 (defstruct simple-struct
42 (really-long-struct-slot-name "defg"))
44 (defparameter *empty-class* (make-instance 'empty-class))
45 (defparameter *simple-class* (make-instance 'simple-class))
46 (defparameter *empty-struct* (make-empty-struct))
47 (defparameter *tiny-struct* (make-tiny-struct))
48 (defparameter *simple-struct* (make-simple-struct))
49 (defparameter *normal-list* '(a b 3))
50 (defparameter *dotted-list* '(a b . 3))
51 (defparameter *cons-pair* '(#c(1 2) . a-symbol))
52 (defparameter *complex* #c(1 2))
53 (defparameter *ratio* 22/7)
54 (defparameter *double* 5.5d0)
55 (defparameter *array* (make-array '(3 3 2) :initial-element nil))
56 (defparameter *vector* (make-array '(20):initial-contents
58 10 11 12 13 14 15 16 17 18 19)))
59 (eval-when (:compile-toplevel :load-toplevel :execute)
60 (defparameter *circle-list1* '(a))
61 (setf (car *circle-list1*) *circle-list1*)
62 (defparameter *circle-list2* '(b))
63 (setf (cdr *circle-list2*) *circle-list2*)
64 (defparameter *circle-list3* '(a b c))
65 (setf (car *circle-list3*) *circle-list3*)
66 (defparameter *circle-list4* '(a b c))
67 (setf (second *circle-list4*) *circle-list4*)
68 (defparameter *circle-list5* '(a b c))
69 (setf (cddr *circle-list5*) *circle-list5*))
71 (defun find-position (object id)
72 (nth-value 0 (sb-aclrepl::find-part-id object id)))
74 (let ((sb-aclrepl::*skip-address-display* t))
75 (sb-aclrepl::inspected-parts object)))
76 (defun description (object)
77 (let ((sb-aclrepl::*skip-address-display* t))
78 (sb-aclrepl::inspected-description object)))
79 (defun elements (object &optional print (skip 0))
80 (let ((sb-aclrepl::*skip-address-display* t))
81 (sb-aclrepl::inspected-elements object print skip)))
82 (defun elements-components (object &optional print (skip 0))
83 (nth-value 0 (elements object print skip )))
84 (defun elements-labels (object &optional print (skip 0))
85 (nth-value 1 (elements object print skip)))
86 (defun elements-count (object &optional print (skip 0))
87 (nth-value 2 (elements object print skip)))
89 (defun labeled-element (object pos &optional print (skip 0))
90 (with-output-to-string (strm)
91 (let ((sb-aclrepl::*skip-address-display* t))
92 (sb-aclrepl::display-labeled-element
93 (aref (the simple-vector (elements-components object print skip)) pos)
94 (aref (the simple-vector (elements-labels object print skip)) pos)
97 (defun display (object &optional print (skip 0))
98 (with-output-to-string (strm)
99 (let ((sb-aclrepl::*skip-address-display* t))
100 (sb-aclrepl::display-inspect object strm print skip))))
102 (defun do-inspect (object)
103 (with-output-to-string (strm)
104 (let ((sb-aclrepl::*skip-address-display* t))
105 (sb-aclrepl::inspector `(quote ,object) nil strm))))
108 (with-output-to-string (strm)
109 (let ((sb-aclrepl::*skip-address-display* t))
110 (sb-aclrepl::istep args strm))))
112 (deftest find.list.0 (find-position *normal-list* 0) 0)
113 (deftest find.list.1 (find-position *normal-list* 0) 0)
114 (deftest find.list.2 (find-position *normal-list* 1) 1)
115 (deftest find.list.3 (find-position *normal-list* 2) 2)
116 (deftest parts.list.1 (sb-aclrepl::parts-count (parts *normal-list*)) 3)
117 (deftest parts.list.2 (sb-aclrepl::component-at (parts *normal-list*) 0) a)
118 (deftest parts.list.3 (sb-aclrepl::component-at (parts *normal-list*) 1) b)
119 (deftest parts.list.4 (sb-aclrepl::component-at (parts *normal-list*) 2) 3)
120 (deftest parts.list.5 (sb-aclrepl::label-at (parts *normal-list*) 0) 0)
121 (deftest parts.list.6 (sb-aclrepl::label-at (parts *normal-list*) 1) 1)
122 (deftest parts.list.7 (sb-aclrepl::label-at (parts *normal-list*) 2) 2)
123 (deftest parts.list.8 (sb-aclrepl::parts-seq-type (parts *normal-list*)) :list)
125 (eval-when (:compile-toplevel :load-toplevel :execute)
126 (defun basename (id &optional print (skip 0))
127 (let ((name (typecase id
128 (symbol (symbol-name id))
129 (string (string-upcase id))
130 (t (format nil "~A" id)))))
132 (string-left-trim "*" (string-right-trim "*" name))
133 (if print (format nil ".P~D" print) "")
134 (if (not (zerop skip)) (format nil ".S~D" skip) ""))))
136 (defun elements-tests-name (id ext print skip)
137 (intern (format nil "ELEM.~A.~A" (basename id print skip) ext))))
139 (defmacro def-elements-tests (object count components labels
140 &optional (print nil) (skip 0))
142 (deftest ,(elements-tests-name object "COUNT" print skip)
143 (elements-count ,object ,print ,skip) ,count)
144 (unless (eq ,components :dont-check)
145 (deftest ,(elements-tests-name object "COMPONENTS" print skip)
146 (elements-components ,object ,print ,skip) ,components))
147 (deftest ,(elements-tests-name object "LABELS" print skip)
148 (elements-labels ,object ,print ,skip) ,labels)))
150 (def-elements-tests *normal-list* 3 #(a b 3) #(0 1 2))
151 (def-elements-tests *dotted-list* 3 #(a b 3) #(0 1 :tail))
153 (def-elements-tests *circle-list1* 2 :dont-check #((0 . "car") (1 . "cdr")))
154 (def-elements-tests *circle-list2* 2 :dont-check #(0 :tail))
155 (def-elements-tests *circle-list3* 3 :dont-check #(0 1 2))
156 (def-elements-tests *circle-list4* 3 :dont-check #(0 1 2))
157 (def-elements-tests *circle-list5* 3 :dont-check #(0 1 :tail))
159 (deftest circle-list1-components
160 (aref (elements-components *circle-list1*) 0) #.*circle-list1*)
161 (deftest circle-list2-components.0
162 (aref (elements-components *circle-list2*) 0) b)
163 (deftest circle-list2-components.1
164 (aref (elements-components *circle-list2*) 1) #.*circle-list2*)
165 (deftest circle-list3-components.0
166 (aref (elements-components *circle-list3*) 0) #.*circle-list3*)
167 (deftest circle-list3-components.1
168 (aref (elements-components *circle-list3*) 1) b)
169 (deftest circle-list3-components.2
170 (aref (elements-components *circle-list3*) 2) c)
171 (deftest circle-list4-components.0
172 (aref (elements-components *circle-list4*) 0) a)
173 (deftest circle-list4-components.1
174 (aref (elements-components *circle-list4*) 1) #.*circle-list4*)
175 (deftest circle-list4-components.2
176 (aref (elements-components *circle-list4*) 2) c)
177 (deftest circle-list5-components.0
178 (aref (elements-components *circle-list5*) 0) a)
179 (deftest circle-list5-components.1
180 (aref (elements-components *circle-list5*) 1) b)
181 (deftest circle-list5-components.2
182 (aref (elements-components *circle-list5*) 2) #.*circle-list5*)
184 (def-elements-tests *cons-pair* 2 #(#c(1 2) a-symbol)
185 #((0 . "car") (1 . "cdr")))
186 (def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag")))
187 (def-elements-tests *ratio* 2 #(22 7)
188 #((0 . "numerator") (1 . "denominator")))
189 (def-elements-tests *vector* 20
190 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
191 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
192 (def-elements-tests *vector* 18
193 #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
194 #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
196 (def-elements-tests *vector* 13
197 #(nil 3 4 5 6 7 8 9 10 11 12 nil 19)
198 #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19)
200 (def-elements-tests *vector* 5
202 #(:ellipses 16 17 18 19)
204 (def-elements-tests *vector* 5
206 #(:ellipses 16 17 18 19)
208 (def-elements-tests *vector* 5
210 #(:ellipses 15 16 :ellipses 19)
212 (def-elements-tests *array* 18
213 #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
215 #((0 . "[0,0,0]") (1 . "[0,0,1]") (2 . "[0,1,0]") (3 . "[0,1,1]")
216 (4 . "[0,2,0]") (5 . "[0,2,1]") (6 . "[1,0,0]") (7 . "[1,0,1]")
217 (8 . "[1,1,0]") (9 . "[1,1,1]") (10 . "[1,2,0]")
218 (11 . "[1,2,1]") (12 . "[2,0,0]") (13 . "[2,0,1]")
219 (14 . "[2,1,0]") (15 . "[2,1,1]") (16 . "[2,2,0]")
222 (def-elements-tests *empty-class* 0 nil nil)
224 (def-elements-tests *simple-class* 3
225 #(#.sb-aclrepl::*inspect-unbound-object-marker* 0 "abc")
226 #((0 . "A") (1 . "SECOND") (2 . "REALLY-LONG-SLOT-NAME")))
227 (def-elements-tests *empty-struct* 0 nil nil)
228 (def-elements-tests *simple-struct* 3
229 #(nil a-value "defg")
230 #((0 . "FIRST") (1 . "SLOT-2")
231 (2 . "REALLY-LONG-STRUCT-SLOT-NAME")))
233 (eval-when (:compile-toplevel :load-toplevel :execute)
234 (defun label-test-name (name pos &optional print (skip 0))
235 (intern (format nil "LABEL.~A.~D" (basename name print skip) pos))))
237 (defmacro def-label-test (object pos label &optional print (skip 0))
238 `(deftest ,(label-test-name object pos print skip)
239 (labeled-element ,object ,pos ,print ,skip) ,label))
241 (def-label-test *simple-struct* 0
242 " 0 FIRST ----------> the symbol NIL")
243 (def-label-test *simple-struct* 1
244 " 1 SLOT-2 ---------> the symbol A-VALUE")
245 (def-label-test *simple-struct* 2
246 " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
247 (def-label-test *simple-class* 0
248 " 0 A --------------> ..unbound..")
249 (def-label-test *simple-class* 1
250 " 1 SECOND ---------> fixnum 0")
251 (def-label-test *simple-class* 2
252 " 2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"")
254 (def-label-test *complex* 0 " 0 real -----------> fixnum 1")
255 (def-label-test *complex* 1 " 1 imag -----------> fixnum 2")
257 (def-label-test *ratio* 0 " 0 numerator ------> fixnum 22")
258 (def-label-test *ratio* 1 " 1 denominator ----> fixnum 7")
260 (def-label-test *dotted-list* 0 " 0-> the symbol A")
261 (def-label-test *dotted-list* 1 " 1-> the symbol B")
262 (def-label-test *dotted-list* 2 "tail-> fixnum 3")
264 (def-label-test *normal-list* 0 " 0-> the symbol A")
265 (def-label-test *normal-list* 1 " 1-> the symbol B")
266 (def-label-test *normal-list* 2 " 2-> fixnum 3")
268 (def-label-test *vector* 0 " 0-> fixnum 0")
269 (def-label-test *vector* 1 " 1-> fixnum 1")
270 (def-label-test *vector* 0 " ..." nil 2)
271 (def-label-test *vector* 1" 2-> fixnum 2" nil 2)
273 (def-label-test *cons-pair* 0
274 " 0 car ------------> complex number #C(1 2)")
275 (def-label-test *cons-pair* 1
276 " 1 cdr ------------> the symbol A-SYMBOL")
278 (deftest nil.parts.0 (elements-count nil) 5)
280 (def-elements-tests *tiny-struct* 1 #(10) #((0 . "FIRST")))
281 (def-elements-tests *tiny-struct* 1
282 #(nil) #(:ellipses) nil 1)
283 (def-elements-tests *tiny-struct* 1
284 #(nil) #(:ellipses) nil 2)
286 (def-elements-tests *double* 0 nil nil)
287 (def-elements-tests *double* 0 nil nil nil 1)
289 (eval-when (:compile-toplevel :load-toplevel :execute)
290 (defun display-test-name (name print skip)
291 (intern (format nil "DISPLAY.~A" (basename name print skip)))))
293 (defmacro def-display-test (object string &optional print (skip 0))
294 `(deftest ,(display-test-name object print skip)
295 (display ,object ,print ,skip) ,string))
297 (def-display-test *cons-pair*
299 0 car ------------> complex number #C(1 2)
300 1 cdr ------------> the symbol A-SYMBOL")
302 (def-display-test *simple-struct*
303 "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
304 0 FIRST ----------> the symbol NIL
305 1 SLOT-2 ---------> the symbol A-VALUE
306 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
308 (def-display-test *simple-struct*
309 "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
311 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\""
314 (def-display-test *vector*
315 "a simple T vector (20)
326 (def-display-test *circle-list1*
328 0 car ------------> a cons cell
329 1 cdr ------------> the symbol NIL")
330 (def-display-test *circle-list2*
331 "a cyclic list with 1 element+tail
333 tail-> a cyclic list with 1 element+tail")
334 (def-display-test *circle-list3*
335 "a normal list with 3 elements
336 0-> a normal list with 3 elements
339 (def-display-test *circle-list4*
340 "a normal list with 3 elements
342 1-> a normal list with 3 elements
344 (def-display-test *circle-list5*
345 "a cyclic list with 2 elements+tail
348 tail-> a cyclic list with 2 elements+tail")
351 ;;; Inspector traversal tests
352 (deftest inspect.0 (istep '(":i" "*simple-struct*"))
353 "#<STRUCTURE-CLASS SIMPLE-STRUCT>
354 0 FIRST ----------> the symbol NIL
355 1 SLOT-2 ---------> the symbol A-VALUE
356 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
358 (deftest istep.0 (prog1
359 (progn (do-inspect *simple-struct*) (istep '("=")))
361 "#<STRUCTURE-CLASS SIMPLE-STRUCT>
362 0 FIRST ----------> the symbol NIL
363 1 SLOT-2 ---------> the symbol A-VALUE
364 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
366 (deftest istep.1 (prog1
367 (progn (do-inspect *simple-struct*) (istep '("first")))
370 0 NAME -----------> a simple-string (3) \"NIL\"
371 1 PACKAGE --------> the COMMON-LISP package
372 2 VALUE ----------> the symbol NIL
373 3 FUNCTION -------> ..unbound..
374 4 PLIST ----------> the symbol NIL")
376 (deftest istep.2 (prog1
377 (progn (do-inspect *simple-struct*) (istep '("first"))
381 0 NAME -----------> a simple-string (7) \"A-VALUE\"
382 1 PACKAGE --------> the ACLREPL-TESTS package
383 2 VALUE ----------> ..unbound..
384 3 FUNCTION -------> ..unbound..
385 4 PLIST ----------> the symbol NIL")
387 (deftest istep.3 (prog1
388 (progn (do-inspect *simple-struct*) (istep '("first"))
389 (istep '(">")) (istep '("<")))
392 0 NAME -----------> a simple-string (3) \"NIL\"
393 1 PACKAGE --------> the COMMON-LISP package
394 2 VALUE ----------> the symbol NIL
395 3 FUNCTION -------> ..unbound..
396 4 PLIST ----------> the symbol NIL")
398 (deftest istep.4 (prog1
399 (progn (do-inspect *simple-struct*) (istep '("first"))
400 (istep '(">")) (istep '("<")) (istep '("tree")))
402 "The current object is:
403 the symbol NIL, which was selected by FIRST
404 #<STRUCTURE-CLASS SIMPLE-STRUCT>, which was selected by (inspect ...)
407 (deftest istep.5 (prog1
408 (progn (do-inspect *simple-struct*) (istep '("first"))
409 (istep '(">")) (istep '("<")) (istep '("-")))
411 "#<STRUCTURE-CLASS SIMPLE-STRUCT>
412 0 FIRST ----------> the symbol NIL
413 1 SLOT-2 ---------> the symbol A-VALUE
414 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
416 (deftest istep.6 (prog1
417 (progn (do-inspect *dotted-list*) (istep '("tail")))
421 (deftest istep.7 (prog1
422 (progn (do-inspect *dotted-list*) (istep '("2")))
426 (deftest istep.8 (prog1 (do-inspect 5.5d0) (reset-cmd))
427 "double-float 5.5d0d")
429 (deftest istep.9 (prog1 (progn (do-inspect 5.5d0) (istep '("-")))
431 "double-float 5.5d0d")
433 (deftest istep.10 (progn (do-inspect 5.5d0) (istep '("-"))
435 "No object is being inspected")