MAKE-LEXENV used NCONC on its arguments, which callers did not expect
[sbcl.git] / contrib / sb-aclrepl / tests.lisp
1 ;; Tests for sb-aclrepl
2
3 (defpackage #:aclrepl-tests
4   (:use #:sb-aclrepl #:cl #:sb-rt))
5 (in-package #:aclrepl-tests)
6
7 (declaim (special sb-aclrepl::*skip-address-display*
8                   sb-aclrepl::*inspect-unbound-object-marker*))
9
10 (setf sb-rt::*catch-errors* nil)
11
12 (rem-all-tests)
13
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)
18
19 ;;; Inspector tests
20
21 (defclass empty-class ()
22   ())
23 (defparameter *empty-class* (make-instance 'empty-class))
24
25 (defclass empty-class ()
26   ())
27
28 (defclass simple-class ()
29   ((a)
30    (second :initform 0)
31    (really-long-slot-name :initform "abc")))
32
33 (defstruct empty-struct
34   )
35
36 (defstruct tiny-struct
37   (first 10))
38
39 (defstruct simple-struct
40   (first)
41   (slot-2 'a-value)
42   (really-long-struct-slot-name "defg"))
43
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
58                              '(0 1 2 3 4 5 6 7 8 9
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*))
71
72 (defun find-position (object id)
73     (nth-value 0 (sb-aclrepl::find-part-id object id)))
74 (defun parts (object)
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)))
89
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)
96        strm))))
97
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))))
102
103 (defun do-inspect (object)
104   (with-output-to-string (strm)
105     (let ((sb-aclrepl::*skip-address-display* t))
106       (sb-aclrepl::inspector `(quote ,object) nil strm))))
107
108 (defun istep (args)
109   (with-output-to-string (strm)
110     (let ((sb-aclrepl::*skip-address-display* t))
111       (sb-aclrepl::istep args strm))))
112
113 (deftest find.list.0 (find-position *normal-list* 0) 0)
114 (deftest find.list.1 (find-position *normal-list* 0) 0)
115 (deftest find.list.2 (find-position *normal-list* 1) 1)
116 (deftest find.list.3 (find-position *normal-list* 2) 2)
117 (deftest parts.list.1 (sb-aclrepl::parts-count (parts *normal-list*)) 3)
118 (deftest parts.list.2 (sb-aclrepl::component-at (parts *normal-list*) 0) a)
119 (deftest parts.list.3 (sb-aclrepl::component-at (parts *normal-list*) 1) b)
120 (deftest parts.list.4 (sb-aclrepl::component-at (parts *normal-list*) 2) 3)
121 (deftest parts.list.5 (sb-aclrepl::label-at (parts *normal-list*) 0) 0)
122 (deftest parts.list.6 (sb-aclrepl::label-at (parts *normal-list*) 1) 1)
123 (deftest parts.list.7 (sb-aclrepl::label-at (parts *normal-list*) 2) 2)
124 (deftest parts.list.8 (sb-aclrepl::parts-seq-type (parts *normal-list*)) :list)
125
126 (eval-when (:compile-toplevel :load-toplevel :execute)
127   (defun basename (id &optional print (skip 0))
128     (let ((name (typecase id
129                   (symbol (symbol-name id))
130                   (string (string-upcase id))
131                   (t (format nil "~A" id)))))
132       (format nil "~A~A~A"
133               (string-left-trim "*" (string-right-trim "*" name))
134               (if print (format nil ".P~D" print) "")
135               (if (not (zerop skip)) (format nil ".S~D" skip) ""))))
136
137   (defun elements-tests-name (id ext print skip)
138     (intern (format nil "ELEM.~A.~A" (basename id print skip) ext))))
139
140 (defmacro def-elements-tests (object count components labels
141                           &optional (print nil) (skip 0))
142   `(progn
143     (deftest ,(elements-tests-name object "COUNT" print skip)
144         (elements-count ,object ,print ,skip) ,count)
145     (unless (eq ,components :dont-check)
146       (deftest ,(elements-tests-name object "COMPONENTS" print skip)
147           (elements-components ,object ,print ,skip) ,components))
148     (deftest ,(elements-tests-name object "LABELS" print skip)
149         (elements-labels ,object ,print ,skip) ,labels)))
150
151 (def-elements-tests *normal-list* 3 #(a b 3) #(0 1 2))
152 (def-elements-tests *dotted-list* 3 #(a b 3) #(0 1 :tail))
153
154 (def-elements-tests *circle-list1* 2 :dont-check #((0 . "car") (1 . "cdr")))
155 (def-elements-tests *circle-list2* 2 :dont-check #(0 :tail))
156 (def-elements-tests *circle-list3* 3 :dont-check #(0 1 2))
157 (def-elements-tests *circle-list4* 3 :dont-check #(0 1 2))
158 (def-elements-tests *circle-list5* 3 :dont-check #(0 1 :tail))
159
160 (deftest circle-list1-components
161     (aref (elements-components *circle-list1*) 0) #.*circle-list1*)
162 (deftest circle-list2-components.0
163     (aref (elements-components *circle-list2*) 0) b)
164 (deftest circle-list2-components.1
165     (aref (elements-components *circle-list2*) 1) #.*circle-list2*)
166 (deftest circle-list3-components.0
167     (aref (elements-components *circle-list3*) 0) #.*circle-list3*)
168 (deftest circle-list3-components.1
169     (aref (elements-components *circle-list3*) 1) b)
170 (deftest circle-list3-components.2
171     (aref (elements-components *circle-list3*) 2) c)
172 (deftest circle-list4-components.0
173     (aref (elements-components *circle-list4*) 0) a)
174 (deftest circle-list4-components.1
175     (aref (elements-components *circle-list4*) 1) #.*circle-list4*)
176 (deftest circle-list4-components.2
177     (aref (elements-components *circle-list4*) 2) c)
178 (deftest circle-list5-components.0
179     (aref (elements-components *circle-list5*) 0) a)
180 (deftest circle-list5-components.1
181     (aref (elements-components *circle-list5*) 1) b)
182 (deftest circle-list5-components.2
183     (aref (elements-components *circle-list5*) 2) #.*circle-list5*)
184
185 (def-elements-tests *cons-pair* 2 #(#c(1 2) a-symbol)
186                 #((0 . "car") (1 . "cdr")))
187 (def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag")))
188 (def-elements-tests *ratio* 2 #(22 7)
189                 #((0 . "numerator") (1 . "denominator")))
190 (case sb-vm::n-word-bits
191   (32
192    (def-elements-tests *bignum* 2
193      #(4154852436 1149780945)
194      #((0 . :HEX32) (1 . :HEX32))))
195   (64
196    (def-elements-tests *bignum* 1
197      #(4938271560493827156)
198      #((0 . :HEX64)))))
199
200 (def-elements-tests *vector* 20
201                 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
202                 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
203 (def-elements-tests *vector* 18
204   #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
205   #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
206   nil 3)
207 (def-elements-tests *vector* 13
208   #(nil 3 4 5 6 7 8 9 10 11 12 nil 19)
209   #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19)
210   10 3)
211 (def-elements-tests *vector* 5
212   #(nil 16 17 18 19)
213   #(:ellipses 16 17 18 19)
214   5 16)
215 (def-elements-tests *vector* 5
216   #(nil 16 17 18 19)
217   #(:ellipses 16 17 18 19)
218   2 16)
219 (def-elements-tests *vector* 5
220   #(nil 15 16 nil 19)
221   #(:ellipses 15 16 :ellipses 19)
222   2 15)
223 (def-elements-tests *array* 18
224    #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
225                 NIL NIL)
226   #((0 . "[0,0,0]") (1 . "[0,0,1]") (2 . "[0,1,0]") (3 . "[0,1,1]")
227     (4 . "[0,2,0]") (5 . "[0,2,1]") (6 . "[1,0,0]") (7 . "[1,0,1]")
228     (8 . "[1,1,0]") (9 . "[1,1,1]") (10 . "[1,2,0]")
229     (11 . "[1,2,1]") (12 . "[2,0,0]") (13 . "[2,0,1]")
230     (14 . "[2,1,0]") (15 . "[2,1,1]") (16 . "[2,2,0]")
231     (17 . "[2,2,1]")))
232
233 (def-elements-tests *empty-class* 0 nil nil)
234 #+ignore ;; FIXME
235 (def-elements-tests *simple-class* 3
236   #(#.sb-aclrepl::*inspect-unbound-object-marker* 0 "abc")
237   #((0 . "A") (1 . "SECOND") (2 . "REALLY-LONG-SLOT-NAME")))
238 (def-elements-tests *empty-struct* 0 nil nil)
239 (def-elements-tests *simple-struct* 3
240   #(nil a-value "defg")
241   #((0 . "FIRST") (1 . "SLOT-2")
242     (2 . "REALLY-LONG-STRUCT-SLOT-NAME")))
243
244 (eval-when (:compile-toplevel :load-toplevel :execute)
245   (defun label-test-name (name pos &optional print (skip 0))
246     (intern (format nil "LABEL.~A.~D" (basename name print skip) pos))))
247
248 (defmacro def-label-test (object pos label &optional print (skip 0))
249   `(deftest ,(label-test-name object pos print skip)
250     (labeled-element ,object ,pos ,print ,skip) ,label))
251
252 (def-label-test *simple-struct* 0
253   "   0 FIRST ----------> the symbol NIL")
254 (def-label-test *simple-struct* 1
255   "   1 SLOT-2 ---------> the symbol A-VALUE")
256 (def-label-test *simple-struct* 2
257  "   2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
258 (def-label-test *simple-class* 0
259   "   0 A --------------> ..unbound..")
260 (def-label-test *simple-class* 1
261   "   1 SECOND ---------> fixnum 0")
262 (def-label-test *simple-class* 2
263   "   2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"")
264
265 (def-label-test *complex* 0 "   0 real -----------> fixnum 1")
266 (def-label-test *complex* 1 "   1 imag -----------> fixnum 2")
267
268 (def-label-test *ratio* 0 "   0 numerator ------> fixnum 22")
269 (def-label-test *ratio* 1 "   1 denominator ----> fixnum 7")
270
271 (def-label-test *dotted-list* 0 "   0-> the symbol A")
272 (def-label-test *dotted-list* 1 "   1-> the symbol B")
273 (def-label-test *dotted-list* 2 "tail-> fixnum 3")
274
275 (def-label-test *normal-list* 0 "   0-> the symbol A")
276 (def-label-test *normal-list* 1 "   1-> the symbol B")
277 (def-label-test *normal-list* 2 "   2-> fixnum 3")
278
279 (def-label-test *vector* 0 "   0-> fixnum 0")
280 (def-label-test *vector* 1 "   1-> fixnum 1")
281 (def-label-test *vector* 0 "   ..." nil 2)
282 (def-label-test *vector* 1"   2-> fixnum 2" nil 2)
283
284 (def-label-test *cons-pair* 0
285     "   0 car ------------> complex number #C(1 2)")
286 (def-label-test *cons-pair* 1
287   "   1 cdr ------------> the symbol A-SYMBOL")
288
289 (deftest nil.parts.0 (elements-count nil) 5)
290
291 (def-elements-tests *tiny-struct* 1 #(10) #((0 . "FIRST")))
292 (def-elements-tests *tiny-struct* 1
293                     #(nil) #(:ellipses) nil 1)
294 (def-elements-tests *tiny-struct* 1
295                     #(nil) #(:ellipses) nil 2)
296
297 (def-elements-tests *double* 0 nil nil)
298 (def-elements-tests *double* 0 nil nil nil 1)
299
300 (eval-when (:compile-toplevel :load-toplevel :execute)
301   (defun display-test-name (name print skip)
302     (intern (format nil "DISPLAY.~A" (basename name print skip)))))
303
304 (defmacro def-display-test (object string &optional print (skip 0))
305   `(deftest ,(display-test-name object print skip)
306     (display ,object ,print ,skip) ,string))
307
308 (def-display-test *cons-pair*
309   "a cons cell
310    0 car ------------> complex number #C(1 2)
311    1 cdr ------------> the symbol A-SYMBOL")
312
313 (def-display-test *simple-struct*
314  "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
315    0 FIRST ----------> the symbol NIL
316    1 SLOT-2 ---------> the symbol A-VALUE
317    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
318
319 (def-display-test *simple-struct*
320   "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
321    ...
322    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\""
323   nil 2)
324
325 (case sb-vm::n-word-bits
326   (32
327    (def-display-test *bignum*
328        "bignum 4938271560493827156 with 2 32-bit words
329    0-> #xF7A60454
330    1-> #x448843D1"))
331   (64
332    (def-display-test *bignum*
333        "bignum 4938271560493827156 with 1 64-bit word
334    0-> #x448843D1F7A60454"
335      )))
336
337 (def-display-test *vector*
338   "a simple T vector (20)
339    ...
340    6-> fixnum 6
341    7-> fixnum 7
342    8-> fixnum 8
343    9-> fixnum 9
344   10-> fixnum 10
345    ...
346   19-> fixnum 19"
347   5 6)
348
349 (def-display-test *circle-list1*
350 "a cons cell
351    0 car ------------> a cons cell
352    1 cdr ------------> the symbol NIL")
353 (def-display-test *circle-list2*
354 "a cyclic list with 1 element+tail
355    0-> the symbol B
356 tail-> a cyclic list with 1 element+tail")
357 (def-display-test *circle-list3*
358 "a normal list with 3 elements
359    0-> a normal list with 3 elements
360    1-> the symbol B
361    2-> the symbol C")
362 (def-display-test *circle-list4*
363 "a normal list with 3 elements
364    0-> the symbol A
365    1-> a normal list with 3 elements
366    2-> the symbol C")
367 (def-display-test *circle-list5*
368   "a cyclic list with 2 elements+tail
369    0-> the symbol A
370    1-> the symbol B
371 tail-> a cyclic list with 2 elements+tail")
372
373
374 ;;; Inspector traversal tests
375 (deftest inspect.0 (progn (setq * *simple-struct*)
376                           (istep '("*")))
377   "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
378    0 FIRST ----------> the symbol NIL
379    1 SLOT-2 ---------> the symbol A-VALUE
380    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
381
382 (deftest istep.0 (progn (setq * *simple-struct*)
383                           (istep '("*"))
384                           (istep '("=")))
385   "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
386    0 FIRST ----------> the symbol NIL
387    1 SLOT-2 ---------> the symbol A-VALUE
388    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
389
390
391 (deftest istep.1 (progn (setq * *simple-struct*)
392                         (istep '("*"))
393                         (istep '("first")))
394 "the symbol NIL
395    0 NAME -----------> a simple-string (3) \"NIL\"
396    1 PACKAGE --------> the COMMON-LISP package
397    2 VALUE ----------> the symbol NIL
398    3 FUNCTION -------> ..unbound..
399    4 PLIST ----------> the symbol NIL")
400
401
402 (deftest istep.2  (progn (setq * *simple-struct*)
403                          (istep '("*"))
404                          (istep '("first"))
405                          (istep '(">")))
406 "the symbol A-VALUE
407    0 NAME -----------> a simple-string (7) \"A-VALUE\"
408    1 PACKAGE --------> the ACLREPL-TESTS package
409    2 VALUE ----------> ..unbound..
410    3 FUNCTION -------> ..unbound..
411    4 PLIST ----------> the symbol NIL")
412
413 (deftest istep.3  (progn (setq * *simple-struct*)
414                          (istep '("*"))
415                          (istep '("first"))
416                          (istep '(">"))
417                          (istep '("<")))
418 "the symbol NIL
419    0 NAME -----------> a simple-string (3) \"NIL\"
420    1 PACKAGE --------> the COMMON-LISP package
421    2 VALUE ----------> the symbol NIL
422    3 FUNCTION -------> ..unbound..
423    4 PLIST ----------> the symbol NIL")
424
425 (deftest istep.4  (progn (setq * *simple-struct*)
426                          (istep '("*"))
427                          (istep '("first"))
428                          (istep '(">"))
429                          (istep '("<"))
430                          (istep '("tree")))
431 "The current object is:
432 the symbol NIL, which was selected by FIRST
433 #<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>, which was selected by (inspect *)
434 ")
435
436 (deftest istep.5  (progn (setq * *simple-struct*)
437                          (istep '("*"))
438                          (istep '("first"))
439                          (istep '(">"))
440                          (istep '("<"))
441                          (istep '("-")))
442   "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
443    0 FIRST ----------> the symbol NIL
444    1 SLOT-2 ---------> the symbol A-VALUE
445    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
446
447 (deftest istep.6 (progn (setq * *dotted-list*)
448                         (istep '("*"))
449                         (istep '("tail")))
450 "fixnum 3")
451
452 (deftest istep.7 (progn (setq * *dotted-list*)
453                         (istep '("*"))
454                         (istep '("2")))
455 "fixnum 3")
456
457 (deftest istep.8 (progn (setq * 5.5d0)
458                         (istep '("*")))
459   "double-float 5.5d0")
460
461 (deftest istep.9 (progn (setq * 5.5d0)
462                         (istep '("-")))
463   "Object has no parent
464 ")
465
466
467