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 *bignum
* 4938271560493827156)
56 (defparameter *array
* (make-array '(3 3 2) :initial-element nil
))
57 (defparameter *vector
* (make-array '(20):initial-contents
59 10 11 12 13 14 15 16 17 18 19)))
60 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
61 (defparameter *circle-list1
* '(a))
62 (setf (car *circle-list1
*) *circle-list1
*)
63 (defparameter *circle-list2
* '(b))
64 (setf (cdr *circle-list2
*) *circle-list2
*)
65 (defparameter *circle-list3
* '(a b c
))
66 (setf (car *circle-list3
*) *circle-list3
*)
67 (defparameter *circle-list4
* '(a b c
))
68 (setf (second *circle-list4
*) *circle-list4
*)
69 (defparameter *circle-list5
* '(a b c
))
70 (setf (cddr *circle-list5
*) *circle-list5
*))
72 (defun find-position (object id
)
73 (nth-value 0 (sb-aclrepl::find-part-id object id
)))
75 (let ((sb-aclrepl::*skip-address-display
* t
))
76 (sb-aclrepl::inspected-parts object
)))
77 (defun description (object)
78 (let ((sb-aclrepl::*skip-address-display
* t
))
79 (sb-aclrepl::inspected-description object
)))
80 (defun elements (object &optional print
(skip 0))
81 (let ((sb-aclrepl::*skip-address-display
* t
))
82 (sb-aclrepl::inspected-elements object print skip
)))
83 (defun elements-components (object &optional print
(skip 0))
84 (nth-value 0 (elements object print skip
)))
85 (defun elements-labels (object &optional print
(skip 0))
86 (nth-value 1 (elements object print skip
)))
87 (defun elements-count (object &optional print
(skip 0))
88 (nth-value 2 (elements object print skip
)))
90 (defun labeled-element (object pos
&optional print
(skip 0))
91 (with-output-to-string (strm)
92 (let ((sb-aclrepl::*skip-address-display
* t
))
93 (sb-aclrepl::display-labeled-element
94 (aref (the simple-vector
(elements-components object print skip
)) pos
)
95 (aref (the simple-vector
(elements-labels object print skip
)) pos
)
98 (defun display (object &optional print
(skip 0))
99 (with-output-to-string (strm)
100 (let ((sb-aclrepl::*skip-address-display
* t
))
101 (sb-aclrepl::display-inspect object strm print skip
))))
104 (with-output-to-string (strm)
105 (let ((sb-aclrepl::*skip-address-display
* t
))
106 (sb-aclrepl::istep args strm
))))
108 (deftest find.list
.0 (find-position *normal-list
* 0) 0)
109 (deftest find.list
.1 (find-position *normal-list
* 0) 0)
110 (deftest find.list
.2 (find-position *normal-list
* 1) 1)
111 (deftest find.list
.3 (find-position *normal-list
* 2) 2)
112 (deftest parts.list
.1 (sb-aclrepl::parts-count
(parts *normal-list
*)) 3)
113 (deftest parts.list
.2 (sb-aclrepl::component-at
(parts *normal-list
*) 0) a
)
114 (deftest parts.list
.3 (sb-aclrepl::component-at
(parts *normal-list
*) 1) b
)
115 (deftest parts.list
.4 (sb-aclrepl::component-at
(parts *normal-list
*) 2) 3)
116 (deftest parts.list
.5 (sb-aclrepl::label-at
(parts *normal-list
*) 0) 0)
117 (deftest parts.list
.6 (sb-aclrepl::label-at
(parts *normal-list
*) 1) 1)
118 (deftest parts.list
.7 (sb-aclrepl::label-at
(parts *normal-list
*) 2) 2)
119 (deftest parts.list
.8 (sb-aclrepl::parts-seq-type
(parts *normal-list
*)) :list
)
121 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
122 (defun basename (id &optional print
(skip 0))
123 (let ((name (typecase id
124 (symbol (symbol-name id
))
125 (string (string-upcase id
))
126 (t (format nil
"~A" id
)))))
128 (string-left-trim "*" (string-right-trim "*" name
))
129 (if print
(format nil
".P~D" print
) "")
130 (if (not (zerop skip
)) (format nil
".S~D" skip
) ""))))
132 (defun elements-tests-name (id ext print skip
)
133 (intern (format nil
"ELEM.~A.~A" (basename id print skip
) ext
))))
135 (defmacro def-elements-tests
(object count components labels
136 &optional
(print nil
) (skip 0))
138 (deftest ,(elements-tests-name object
"COUNT" print skip
)
139 (elements-count ,object
,print
,skip
) ,count
)
140 (unless (eq ,components
:dont-check
)
141 (deftest ,(elements-tests-name object
"COMPONENTS" print skip
)
142 (elements-components ,object
,print
,skip
) ,components
))
143 (deftest ,(elements-tests-name object
"LABELS" print skip
)
144 (elements-labels ,object
,print
,skip
) ,labels
)))
146 (def-elements-tests *normal-list
* 3 #(a b
3) #(0 1 2))
147 (def-elements-tests *dotted-list
* 3 #(a b
3) #(0 1 :tail
))
149 (def-elements-tests *circle-list1
* 2 :dont-check
#((0 .
"car") (1 .
"cdr")))
150 (def-elements-tests *circle-list2
* 2 :dont-check
#(0 :tail
))
151 (def-elements-tests *circle-list3
* 3 :dont-check
#(0 1 2))
152 (def-elements-tests *circle-list4
* 3 :dont-check
#(0 1 2))
153 (def-elements-tests *circle-list5
* 3 :dont-check
#(0 1 :tail
))
155 (deftest circle-list1-components
156 (aref (elements-components *circle-list1
*) 0) #.
*circle-list1
*)
157 (deftest circle-list2-components
.0
158 (aref (elements-components *circle-list2
*) 0) b
)
159 (deftest circle-list2-components
.1
160 (aref (elements-components *circle-list2
*) 1) #.
*circle-list2
*)
161 (deftest circle-list3-components
.0
162 (aref (elements-components *circle-list3
*) 0) #.
*circle-list3
*)
163 (deftest circle-list3-components
.1
164 (aref (elements-components *circle-list3
*) 1) b
)
165 (deftest circle-list3-components
.2
166 (aref (elements-components *circle-list3
*) 2) c
)
167 (deftest circle-list4-components
.0
168 (aref (elements-components *circle-list4
*) 0) a
)
169 (deftest circle-list4-components
.1
170 (aref (elements-components *circle-list4
*) 1) #.
*circle-list4
*)
171 (deftest circle-list4-components
.2
172 (aref (elements-components *circle-list4
*) 2) c
)
173 (deftest circle-list5-components
.0
174 (aref (elements-components *circle-list5
*) 0) a
)
175 (deftest circle-list5-components
.1
176 (aref (elements-components *circle-list5
*) 1) b
)
177 (deftest circle-list5-components
.2
178 (aref (elements-components *circle-list5
*) 2) #.
*circle-list5
*)
180 (def-elements-tests *cons-pair
* 2 #(#c
(1 2) a-symbol
)
181 #((0 .
"car") (1 .
"cdr")))
182 (def-elements-tests *complex
* 2 #(1 2) #((0 .
"real") (1 .
"imag")))
183 (def-elements-tests *ratio
* 2 #(22 7)
184 #((0 .
"numerator") (1 .
"denominator")))
185 (case sb-vm
::n-word-bits
187 (def-elements-tests *bignum
* 2
188 #(4154852436 1149780945)
189 #((0 .
:HEX32
) (1 .
:HEX32
))))
191 (def-elements-tests *bignum
* 1
192 #(4938271560493827156)
195 (def-elements-tests *vector
* 20
196 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
197 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
198 (def-elements-tests *vector
* 18
199 #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
200 #(:ellipses
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
202 (def-elements-tests *vector
* 13
203 #(nil 3 4 5 6 7 8 9 10 11 12 nil
19)
204 #(:ellipses
3 4 5 6 7 8 9 10 11 12 :ellipses
19)
206 (def-elements-tests *vector
* 5
208 #(:ellipses
16 17 18 19)
210 (def-elements-tests *vector
* 5
212 #(:ellipses
16 17 18 19)
214 (def-elements-tests *vector
* 5
216 #(:ellipses
15 16 :ellipses
19)
218 (def-elements-tests *array
* 18
219 #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
221 #((0 .
"[0,0,0]") (1 .
"[0,0,1]") (2 .
"[0,1,0]") (3 .
"[0,1,1]")
222 (4 .
"[0,2,0]") (5 .
"[0,2,1]") (6 .
"[1,0,0]") (7 .
"[1,0,1]")
223 (8 .
"[1,1,0]") (9 .
"[1,1,1]") (10 .
"[1,2,0]")
224 (11 .
"[1,2,1]") (12 .
"[2,0,0]") (13 .
"[2,0,1]")
225 (14 .
"[2,1,0]") (15 .
"[2,1,1]") (16 .
"[2,2,0]")
228 (def-elements-tests *empty-class
* 0 nil nil
)
230 (def-elements-tests *simple-class
* 3
231 #(#.sb-aclrepl
::*inspect-unbound-object-marker
* 0 "abc")
232 #((0 .
"A") (1 .
"SECOND") (2 .
"REALLY-LONG-SLOT-NAME")))
233 (def-elements-tests *empty-struct
* 0 nil nil
)
234 (def-elements-tests *simple-struct
* 3
235 #(nil a-value
"defg")
236 #((0 .
"FIRST") (1 .
"SLOT-2")
237 (2 .
"REALLY-LONG-STRUCT-SLOT-NAME")))
239 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
240 (defun label-test-name (name pos
&optional print
(skip 0))
241 (intern (format nil
"LABEL.~A.~D" (basename name print skip
) pos
))))
243 (defmacro def-label-test
(object pos label
&optional print
(skip 0))
244 `(deftest ,(label-test-name object pos print skip
)
245 (labeled-element ,object
,pos
,print
,skip
) ,label
))
247 (def-label-test *simple-struct
* 0
248 " 0 FIRST ----------> the symbol NIL")
249 (def-label-test *simple-struct
* 1
250 " 1 SLOT-2 ---------> the symbol A-VALUE")
251 (def-label-test *simple-struct
* 2
252 " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
253 (def-label-test *simple-class
* 0
254 " 0 A --------------> ..unbound..")
255 (def-label-test *simple-class
* 1
256 " 1 SECOND ---------> fixnum 0")
257 (def-label-test *simple-class
* 2
258 " 2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"")
260 (def-label-test *complex
* 0 " 0 real -----------> fixnum 1")
261 (def-label-test *complex
* 1 " 1 imag -----------> fixnum 2")
263 (def-label-test *ratio
* 0 " 0 numerator ------> fixnum 22")
264 (def-label-test *ratio
* 1 " 1 denominator ----> fixnum 7")
266 (def-label-test *dotted-list
* 0 " 0-> the symbol A")
267 (def-label-test *dotted-list
* 1 " 1-> the symbol B")
268 (def-label-test *dotted-list
* 2 "tail-> fixnum 3")
270 (def-label-test *normal-list
* 0 " 0-> the symbol A")
271 (def-label-test *normal-list
* 1 " 1-> the symbol B")
272 (def-label-test *normal-list
* 2 " 2-> fixnum 3")
274 (def-label-test *vector
* 0 " 0-> fixnum 0")
275 (def-label-test *vector
* 1 " 1-> fixnum 1")
276 (def-label-test *vector
* 0 " ..." nil
2)
277 (def-label-test *vector
* 1" 2-> fixnum 2" nil
2)
279 (def-label-test *cons-pair
* 0
280 " 0 car ------------> complex number #C(1 2)")
281 (def-label-test *cons-pair
* 1
282 " 1 cdr ------------> the symbol A-SYMBOL")
284 (deftest nil.parts
.0 (elements-count nil
) 5)
286 (def-elements-tests *tiny-struct
* 1 #(10) #((0 .
"FIRST")))
287 (def-elements-tests *tiny-struct
* 1
288 #(nil) #(:ellipses
) nil
1)
289 (def-elements-tests *tiny-struct
* 1
290 #(nil) #(:ellipses
) nil
2)
292 (def-elements-tests *double
* 0 nil nil
)
293 (def-elements-tests *double
* 0 nil nil nil
1)
295 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
296 (defun display-test-name (name print skip
)
297 (intern (format nil
"DISPLAY.~A" (basename name print skip
)))))
299 (defmacro def-display-test
(object string
&optional print
(skip 0))
300 `(deftest ,(display-test-name object print skip
)
301 (display ,object
,print
,skip
) ,string
))
303 (def-display-test *cons-pair
*
305 0 car ------------> complex number #C(1 2)
306 1 cdr ------------> the symbol A-SYMBOL")
308 (def-display-test *simple-struct
*
309 "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
310 0 FIRST ----------> the symbol NIL
311 1 SLOT-2 ---------> the symbol A-VALUE
312 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
314 (def-display-test *simple-struct
*
315 "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
317 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\""
320 (case sb-vm
::n-word-bits
322 (def-display-test *bignum
*
323 "bignum 4938271560493827156 with 2 32-bit words
327 (def-display-test *bignum
*
328 "bignum 4938271560493827156 with 1 64-bit word
329 0-> #x448843D1F7A60454"
332 (def-display-test *vector
*
333 "a simple T vector (20)
344 (def-display-test *circle-list1
*
346 0 car ------------> a cons cell
347 1 cdr ------------> the symbol NIL")
348 (def-display-test *circle-list2
*
349 "a cyclic list with 1 element+tail
351 tail-> a cyclic list with 1 element+tail")
352 (def-display-test *circle-list3
*
353 "a normal list with 3 elements
354 0-> a normal list with 3 elements
357 (def-display-test *circle-list4
*
358 "a normal list with 3 elements
360 1-> a normal list with 3 elements
362 (def-display-test *circle-list5
*
363 "a cyclic list with 2 elements+tail
366 tail-> a cyclic list with 2 elements+tail")
369 ;;; Inspector traversal tests
370 (deftest inspect
.0 (progn (setq * *simple-struct
*)
372 "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
373 0 FIRST ----------> the symbol NIL
374 1 SLOT-2 ---------> the symbol A-VALUE
375 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
377 (deftest istep
.0 (progn (setq * *simple-struct
*)
380 "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
381 0 FIRST ----------> the symbol NIL
382 1 SLOT-2 ---------> the symbol A-VALUE
383 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
386 (deftest istep
.1 (progn (setq * *simple-struct
*)
390 0 NAME -----------> a simple-string (3) \"NIL\"
391 1 PACKAGE --------> the COMMON-LISP package
392 2 VALUE ----------> the symbol NIL
393 3 FUNCTION -------> ..unbound..
394 4 PLIST ----------> the symbol NIL")
397 (deftest istep
.2 (progn (setq * *simple-struct
*)
402 0 NAME -----------> a simple-string (7) \"A-VALUE\"
403 1 PACKAGE --------> the ACLREPL-TESTS package
404 2 VALUE ----------> ..unbound..
405 3 FUNCTION -------> ..unbound..
406 4 PLIST ----------> the symbol NIL")
408 (deftest istep
.3 (progn (setq * *simple-struct
*)
414 0 NAME -----------> a simple-string (3) \"NIL\"
415 1 PACKAGE --------> the COMMON-LISP package
416 2 VALUE ----------> the symbol NIL
417 3 FUNCTION -------> ..unbound..
418 4 PLIST ----------> the symbol NIL")
420 (deftest istep
.4 (progn (setq * *simple-struct
*)
426 "The current object is:
427 the symbol NIL, which was selected by FIRST
428 #<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>, which was selected by (inspect *)
431 (deftest istep
.5 (progn (setq * *simple-struct
*)
437 "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
438 0 FIRST ----------> the symbol NIL
439 1 SLOT-2 ---------> the symbol A-VALUE
440 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
442 (deftest istep
.6 (progn (setq * *dotted-list
*)
447 (deftest istep
.7 (progn (setq * *dotted-list
*)
452 (deftest istep
.8 (progn (setq * 5.5d0
)
454 "double-float 5.5d0")
456 (deftest istep
.9 (progn (setq * 5.5d0
)
458 "Object has no parent