1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (load "assertoid.lisp")
13 (use-package "ASSERTOID")
15 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
17 ;;; Type mismatch of slot default init value isn't an error until the
18 ;;; default init value is actually used. (The justification is
19 ;;; somewhat bogus, but the requirement is clear.)
20 (defstruct person age
(name 007 :type string
)) ; not an error until 007 used
21 (make-person :name
"James") ; not an error, 007 not used
22 (assert (raises-error?
(make-person) type-error
))
23 (assert (raises-error?
(setf (person-name (make-person :name
"Q")) 1)
26 ;;; An &AUX variable in a boa-constructor without a default value
27 ;;; means "do not initialize slot" and does not cause type error
28 (defstruct (boa-saux (:constructor make-boa-saux
(&aux a
(b 3) (c))))
29 (a #\
! :type
(integer 1 2))
30 (b #\? :type
(integer 3 4))
31 (c #\
# :type
(integer 5 6)))
32 (let ((s (make-boa-saux)))
33 (setf (boa-saux-a s
) 1)
34 (setf (boa-saux-c s
) 5)
35 (assert (eql (boa-saux-a s
) 1))
36 (assert (eql (boa-saux-b s
) 3))
37 (assert (eql (boa-saux-c s
) 5)))
40 (defstruct (astronaut (:include person
)
43 (favorite-beverage 'tang
))
44 (let ((x (make-astronaut :name
"Buzz" :helmet-size
17.5)))
45 (assert (equal (person-name x
) "Buzz"))
46 (assert (equal (astro-name x
) "Buzz"))
47 (assert (eql (astro-favorite-beverage x
) 'tang
))
48 (assert (null (astro-age x
))))
49 (defstruct (ancient-astronaut (:include person
(age 77)))
51 (favorite-beverage 'tang
))
52 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name
"John")) 77))
54 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
55 (defstruct (binop (:type list
) :named
(:initial-offset
2))
56 (operator '?
:type symbol
)
59 (defstruct (annotated-binop (:type list
)
62 commutative associative identity
)
63 (assert (equal (make-annotated-binop :operator
'*
69 '(nil nil binop
* x
5 nil nil nil t t
1)))
71 ;;; effect of :NAMED on :TYPE
72 (defstruct (named-binop (:type list
) :named
)
73 (operator '?
:type symbol
)
76 (let ((named-binop (make-named-binop :operator
'+ :operand-1
'x
:operand-2
5)))
77 ;; The data representation is specified to look like this.
78 (assert (equal named-binop
'(named-binop + x
5)))
79 ;; A meaningful NAMED-BINOP-P is defined.
80 (assert (named-binop-p named-binop
))
81 (assert (named-binop-p (copy-list named-binop
)))
82 (assert (not (named-binop-p (cons 11 named-binop
))))
83 (assert (not (named-binop-p (find-package :cl
)))))
89 (firetrucks 1 :type fixnum
)
91 (elevation 5128 :read-only t
))
92 (let ((town1 (make-town :area
0 :watertowers
0)))
93 (assert (town-p town1
))
94 (assert (not (town-p 1)))
95 (assert (eql (town-area town1
) 0))
96 (assert (eql (town-elevation town1
) 5128))
97 (assert (null (town-population town1
)))
98 (setf (town-population town1
) 99)
99 (assert (eql (town-population town1
) 99))
100 (let ((town2 (copy-town town1
)))
101 (dolist (slot-accessor-name '(town-area
106 (assert (eql (funcall slot-accessor-name town1
)
107 (funcall slot-accessor-name town2
))))
108 (assert (not (fboundp '(setf town-elevation
)))))) ; 'cause it's :READ-ONLY
111 (defstruct (clown (:conc-name bozo-
))
115 (let ((funny-clown (make-clown)))
116 (assert (eql (bozo-nose-color funny-clown
) 'red
)))
117 (defstruct (klown (:constructor make-up-klown
)
118 (:copier clone-klown
)
119 (:predicate is-a-bozo-p
))
123 (assert (is-a-bozo-p (make-up-klown)))
125 ;;;; systematically testing variants of DEFSTRUCT:
126 ;;;; * native, :TYPE LIST, and :TYPE VECTOR
128 ;;; FIXME: things to test:
129 ;;; * Slot readers work.
130 ;;; * Slot writers work.
131 ;;; * Predicates work.
133 ;;; FIXME: things that would be nice to test systematically someday:
134 ;;; * constructors (default, boa..)
136 ;;; * no type checks when (> SPEED SAFETY)
137 ;;; * Tests of inclusion would be good. (It's tested very lightly
138 ;;; above, and then tested a fair amount by the system compiling
141 (defun string+ (&rest rest
)
142 (apply #'concatenate
'string
143 (mapcar #'string rest
)))
144 (defun symbol+ (&rest rest
)
145 (values (intern (apply #'string
+ rest
))))
147 (defun accessor-name (conc-name slot-name
)
148 (symbol+ conc-name slot-name
))
150 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
151 ;;; to read and write a structure slot.
152 (defun read-slot-notinline (conc-name slot-name instance
)
153 (funcall (accessor-name conc-name slot-name
) instance
))
154 (defun write-slot-notinline (new-value conc-name slot-name instance
)
155 (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name
)))
158 ;;; Use inline expansions of slot accessors, if possible, to read and
159 ;;; write a structure slot.
160 (defun read-slot-inline (conc-name slot-name instance
)
161 (funcall (compile nil
163 (,(accessor-name conc-name slot-name
) instance
)))
165 (defun write-slot-inline (new-value conc-name slot-name instance
)
166 (funcall (compile nil
167 `(lambda (new-value instance
)
168 (setf (,(accessor-name conc-name slot-name
) instance
)
173 ;;; Read a structure slot, checking that the inline and out-of-line
174 ;;; accessors give the same result.
175 (defun read-slot (conc-name slot-name instance
)
176 (let ((inline-value (read-slot-inline conc-name slot-name instance
))
177 (notinline-value (read-slot-notinline conc-name slot-name instance
)))
178 (assert (eql inline-value notinline-value
))
181 ;;; Write a structure slot, using INLINEP argument to decide
182 ;;; on inlineness of accessor used.
183 (defun write-slot (new-value conc-name slot-name instance inlinep
)
185 (write-slot-inline new-value conc-name slot-name instance
)
186 (write-slot-notinline new-value conc-name slot-name instance
)))
188 ;;; bound during the tests so that we can get to it even if the
189 ;;; debugger is having a bad day
192 (defmacro test-variant
(defstructname &key colontype boa-constructor-p
)
195 (format t
"~&/beginning PROGN for COLONTYPE=~S~%" ',colontype
)
197 (defstruct (,defstructname
198 ,@(when colontype
`((:type
,colontype
)))
199 ,@(when boa-constructor-p
200 `((:constructor
,(symbol+ "CREATE-" defstructname
)
203 (optional-test 2 optional-test-p
)
206 (no-home-comment "Home package CL not provided.")
207 (comment (if home-p
"" no-home-comment
))
208 (refcount (if optional-test-p optional-test nil
))
212 ;; some ordinary tagged slots
214 (home nil
:type package
:read-only t
)
215 (comment "" :type simple-string
)
217 (weight 1.0 :type single-float
)
218 (hash 1 :type
(integer 1 #.
(* 3 most-positive-fixnum
)) :read-only t
)
219 ;; more ordinary tagged slots
220 (refcount 0 :type
(and unsigned-byte fixnum
)))
222 (format t
"~&/done with DEFSTRUCT~%")
224 (let* ((cn (string+ ',defstructname
"-")) ; conc-name
225 (ctor (symbol-function ',(symbol+ (if boa-constructor-p
229 (*instance
* (funcall ctor
230 ,@(unless boa-constructor-p
232 ,@(when boa-constructor-p
234 :home
(find-package :cl
)
235 :hash
(+ 14 most-positive-fixnum
)
236 ,@(unless boa-constructor-p
239 ;; Check that ctor set up slot values correctly.
240 (format t
"~&/checking constructed structure~%")
241 (assert (string= "some id" (read-slot cn
"ID" *instance
*)))
242 (assert (eql (find-package :cl
) (read-slot cn
"HOME" *instance
*)))
243 (assert (string= "" (read-slot cn
"COMMENT" *instance
*)))
244 (assert (= 1.0 (read-slot cn
"WEIGHT" *instance
*)))
245 (assert (eql (+ 14 most-positive-fixnum
)
246 (read-slot cn
"HASH" *instance
*)))
247 (assert (= 1 (read-slot cn
"REFCOUNT" *instance
*)))
249 ;; There should be no writers for read-only slots.
250 (format t
"~&/checking no read-only writers~%")
251 (assert (not (fboundp `(setf ,(symbol+ cn
"HOME")))))
252 (assert (not (fboundp `(setf ,(symbol+ cn
"HASH")))))
253 ;; (Read-only slot values are checked in the loop below.)
255 (dolist (inlinep '(t nil
))
256 (format t
"~&/doing INLINEP=~S~%" inlinep
)
257 ;; Fiddle with writable slot values.
258 (let ((new-id (format nil
"~S" (random 100)))
259 (new-comment (format nil
"~X" (random 5555)))
260 (new-weight (random 10.0)))
261 (write-slot new-id cn
"ID" *instance
* inlinep
)
262 (write-slot new-comment cn
"COMMENT" *instance
* inlinep
)
263 (write-slot new-weight cn
"WEIGHT" *instance
* inlinep
)
264 (assert (eql new-id
(read-slot cn
"ID" *instance
*)))
265 (assert (eql new-comment
(read-slot cn
"COMMENT" *instance
*)))
266 ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
267 ;; (error "WEIGHT mismatch: ~S vs. ~S"
268 ;; new-weight (read-slot cn "WEIGHT" *instance*)))
269 (assert (eql new-weight
(read-slot cn
"WEIGHT" *instance
*)))))
270 (format t
"~&/done with INLINEP loop~%")
272 ;; :TYPE FOO objects don't go in the Lisp type system, so we
273 ;; can't test TYPEP stuff for them.
275 ;; FIXME: However, when they're named, they do define
276 ;; predicate functions, and we could test those.
278 `(;; Fiddle with predicate function.
279 (let ((pred-name (symbol+ ',defstructname
"-P")))
280 (format t
"~&/doing tests on PRED-NAME=~S~%" pred-name
)
281 (assert (funcall pred-name
*instance
*))
282 (assert (not (funcall pred-name
14)))
283 (assert (not (funcall pred-name
"test")))
284 (assert (not (funcall pred-name
(make-hash-table))))
286 (compile nil
`(lambda (x) (,pred-name x
)))))
287 (format t
"~&/doing COMPILED-PRED tests~%")
288 (assert (funcall compiled-pred
*instance
*))
289 (assert (not (funcall compiled-pred
14)))
290 (assert (not (funcall compiled-pred
#()))))
291 ;; Fiddle with TYPEP.
292 (format t
"~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype
)
293 (assert (typep *instance
* ',defstructname
))
294 (assert (not (typep 0 ',defstructname
)))
295 (assert (funcall (symbol+ "TYPEP") *instance
* ',defstructname
))
296 (assert (not (funcall (symbol+ "TYPEP") nil
',defstructname
)))
297 (let* ((typename ',defstructname
)
299 (compile nil
`(lambda (x) (typep x
',typename
)))))
300 (assert (funcall compiled-typep
*instance
*))
301 (assert (not (funcall compiled-typep nil
))))))))
303 (format t
"~&/done with PROGN for COLONTYPE=~S~%" ',colontype
)))
305 (test-variant vanilla-struct
)
306 (test-variant vector-struct
:colontype vector
)
307 (test-variant list-struct
:colontype list
)
308 (test-variant vanilla-struct
:boa-constructor-p t
)
309 (test-variant vector-struct
:colontype vector
:boa-constructor-p t
)
310 (test-variant list-struct
:colontype list
:boa-constructor-p t
)
313 ;;;; testing raw slots harder
315 ;;;; The offsets of raw slots need to be rescaled during the punning
316 ;;;; process which is used to access them. That seems like a good
317 ;;;; place for errors to lurk, so we'll try hunting for them by
318 ;;;; verifying that all the raw slot data gets written successfully
319 ;;;; into the object, can be copied with the object, and can then be
320 ;;;; read back out (with none of it ending up bogusly outside the
321 ;;;; object, so that it couldn't be copied, or bogusly overwriting
322 ;;;; some other raw slot).
325 (a (expt 2 30) :type
(unsigned-byte 32))
326 (b 0.1 :type single-float
)
327 (c 0.2d0
:type double-float
)
328 (d #c
(0.3
0.3) :type
(complex single-float
))
329 unraw-slot-just-for-variety
330 (e #c
(0.4d0
0.4d0
) :type
(complex double-float
))
331 (aa (expt 2 30) :type
(unsigned-byte 32))
332 (bb 0.1 :type single-float
)
333 (cc 0.2d0
:type double-float
)
334 (dd #c
(0.3
0.3) :type
(complex single-float
))
335 (ee #c
(0.4d0
0.4d0
) :type
(complex double-float
)))
337 (defvar *manyraw
* (make-manyraw))
339 (assert (eql (manyraw-a *manyraw
*) (expt 2 30)))
340 (assert (eql (manyraw-b *manyraw
*) 0.1))
341 (assert (eql (manyraw-c *manyraw
*) 0.2d0
))
342 (assert (eql (manyraw-d *manyraw
*) #c
(0.3
0.3)))
343 (assert (eql (manyraw-e *manyraw
*) #c
(0.4d0
0.4d0
)))
344 (assert (eql (manyraw-aa *manyraw
*) (expt 2 30)))
345 (assert (eql (manyraw-bb *manyraw
*) 0.1))
346 (assert (eql (manyraw-cc *manyraw
*) 0.2d0
))
347 (assert (eql (manyraw-dd *manyraw
*) #c
(0.3
0.3)))
348 (assert (eql (manyraw-ee *manyraw
*) #c
(0.4d0
0.4d0
)))
350 (setf (manyraw-aa *manyraw
*) (expt 2 31)
351 (manyraw-bb *manyraw
*) 0.11
352 (manyraw-cc *manyraw
*) 0.22d0
353 (manyraw-dd *manyraw
*) #c
(0.33
0.33)
354 (manyraw-ee *manyraw
*) #c
(0.44d0
0.44d0
))
356 (let ((copy (copy-manyraw *manyraw
*)))
357 (assert (eql (manyraw-a copy
) (expt 2 30)))
358 (assert (eql (manyraw-b copy
) 0.1))
359 (assert (eql (manyraw-c copy
) 0.2d0
))
360 (assert (eql (manyraw-d copy
) #c
(0.3
0.3)))
361 (assert (eql (manyraw-e copy
) #c
(0.4d0
0.4d0
)))
362 (assert (eql (manyraw-aa copy
) (expt 2 31)))
363 (assert (eql (manyraw-bb copy
) 0.11))
364 (assert (eql (manyraw-cc copy
) 0.22d0
))
365 (assert (eql (manyraw-dd copy
) #c
(0.33
0.33)))
366 (assert (eql (manyraw-ee copy
) #c
(0.44d0
0.44d0
))))
368 ;;;; miscellaneous old bugs
370 (defstruct ya-struct
)
371 (when (ignore-errors (or (ya-struct-p) 12))
372 (error "YA-STRUCT-P of no arguments should signal an error."))
373 (when (ignore-errors (or (ya-struct-p 'too
'many
'arguments
) 12))
374 (error "YA-STRUCT-P of three arguments should signal an error."))
376 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
377 ;;; declared inside on the theory that slot types were already
378 ;;; checked, which bogusly suppressed unbound-variable and other
379 ;;; checks within the evaluation of initforms.
381 (defstruct (bug210a (:constructor bug210a
()))
385 ;;; Because of bug 210, this assertion used to fail.
386 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable
))
387 ;;; Even with bug 210, these assertions succeeded.
388 (assert (typep (nth-value 1 (ignore-errors *bug210
*)) 'unbound-variable
))
389 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable
))
391 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
392 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
393 ;;; setting up compiler-layout information would run before the
394 ;;; constructor function installing the layout was compiled. Make sure
395 ;;; that doesn't happen again.
396 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x
(y :not
)))
397 (assert (not (find-class 'foo-0-7-8-53 nil
)))
399 (assert (find-class 'foo-0-7-8-53 nil
))
400 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x
:s
)))
401 (assert (eq (foo-0-7-8-53-x foo-0-7-8-53
) :s
))
402 (assert (eq (foo-0-7-8-53-y foo-0-7-8-53
) :not
)))
404 ;;; tests of behaviour of colliding accessors.
405 (defstruct (bug127-foo (:conc-name bug127-baz-
)) a
)
406 (assert (= (bug127-baz-a (make-bug127-foo :a
1)) 1))
407 (defstruct (bug127-bar (:conc-name bug127-baz-
) (:include bug127-foo
)) b
)
408 (assert (= (bug127-baz-a (make-bug127-bar :a
1 :b
2)) 1))
409 (assert (= (bug127-baz-b (make-bug127-bar :a
1 :b
2)) 2))
410 (assert (= (bug127-baz-a (make-bug127-foo :a
1)) 1))
412 (defun bug127-flurble (x)
414 (defstruct bug127 flurble
)
415 (assert (= (bug127-flurble (make-bug127 :flurble
7)) 7))
417 (defstruct bug127-a b-c
)
418 (assert (= (bug127-a-b-c (make-bug127-a :b-c
9)) 9))
419 (defstruct (bug127-a-b (:include bug127-a
)) c
)
420 (assert (= (bug127-a-b-c (make-bug127-a :b-c
9)) 9))
421 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c
11 :c
13)) 11))
423 (defstruct (bug127-e (:conc-name bug127--
)) foo
)
424 (assert (= (bug127--foo (make-bug127-e :foo
3)) 3))
425 (defstruct (bug127-f (:conc-name bug127--
)) foo
)
426 (assert (= (bug127--foo (make-bug127-f :foo
3)) 3))
427 (assert (raises-error?
(bug127--foo (make-bug127-e :foo
3)) type-error
))
429 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
431 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
433 (defstruct (conc-name-syntax :conc-name
) a-conc-name-slot
)
434 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot
'y
))
436 ;;; and further :CONC-NAME NIL was being wrongly treated:
437 (defpackage "DEFSTRUCT-TEST-SCRATCH")
438 (defstruct (conc-name-nil :conc-name
)
439 defstruct-test-scratch
::conc-name-nil-slot
)
440 (assert (= (defstruct-test-scratch::conc-name-nil-slot
441 (make-conc-name-nil :conc-name-nil-slot
1)) 1))
442 (assert (raises-error?
(conc-name-nil-slot (make-conc-name-nil))
446 (format t
"~&/returning success~%")
447 (quit :unix-status
104)