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
23 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
24 (assert (raises-error?
(make-person) type-error
))
25 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
26 (assert (raises-error?
(setf (person-name (make-person :name
"Q")) 1)
29 ;;; An &AUX variable in a boa-constructor without a default value
30 ;;; means "do not initialize slot" and does not cause type error
31 (declaim (notinline opaque-identity
))
32 (defun opaque-identity (x) x
)
34 (defstruct (boa-saux (:constructor make-boa-saux
(&aux a
(b 3) (c))))
35 (a #\
! :type
(integer 1 2))
36 (b #\? :type
(integer 3 4))
37 (c #\
# :type
(integer 5 6)))
38 (let ((s (make-boa-saux)))
39 (locally (declare (optimize (safety 3))
41 (assert (raises-error?
(opaque-identity (boa-saux-a s
)) type-error
)))
42 (setf (boa-saux-a s
) 1)
43 (setf (boa-saux-c s
) 5)
44 (assert (eql (boa-saux-a s
) 1))
45 (assert (eql (boa-saux-b s
) 3))
46 (assert (eql (boa-saux-c s
) 5)))
47 ; these two checks should be
50 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
51 (let ((s (make-boa-saux)))
52 (locally (declare (optimize (safety 0))
54 (assert (eql (opaque-identity (boa-saux-a s
)) 0)))
55 (setf (boa-saux-a s
) 1)
56 (setf (boa-saux-c s
) 5)
57 (assert (eql (boa-saux-a s
) 1))
58 (assert (eql (boa-saux-b s
) 3))
59 (assert (eql (boa-saux-c s
) 5)))
61 (let ((s (make-boa-saux)))
62 (locally (declare (optimize (safety 3))
63 (notinline boa-saux-a
))
64 (assert (raises-error?
(opaque-identity (boa-saux-a s
)) type-error
)))
65 (setf (boa-saux-a s
) 1)
66 (setf (boa-saux-c s
) 5)
67 (assert (eql (boa-saux-a s
) 1))
68 (assert (eql (boa-saux-b s
) 3))
69 (assert (eql (boa-saux-c s
) 5)))
72 (defstruct (astronaut (:include person
)
75 (favorite-beverage 'tang
))
76 (let ((x (make-astronaut :name
"Buzz" :helmet-size
17.5)))
77 (assert (equal (person-name x
) "Buzz"))
78 (assert (equal (astro-name x
) "Buzz"))
79 (assert (eql (astro-favorite-beverage x
) 'tang
))
80 (assert (null (astro-age x
))))
81 (defstruct (ancient-astronaut (:include person
(age 77)))
83 (favorite-beverage 'tang
))
84 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name
"John")) 77))
86 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
87 (defstruct (binop (:type list
) :named
(:initial-offset
2))
88 (operator '?
:type symbol
)
91 (defstruct (annotated-binop (:type list
)
94 commutative associative identity
)
95 (assert (equal (make-annotated-binop :operator
'*
101 '(nil nil binop
* x
5 nil nil nil t t
1)))
103 ;;; effect of :NAMED on :TYPE
104 (defstruct (named-binop (:type list
) :named
)
105 (operator '?
:type symbol
)
108 (let ((named-binop (make-named-binop :operator
'+ :operand-1
'x
:operand-2
5)))
109 ;; The data representation is specified to look like this.
110 (assert (equal named-binop
'(named-binop + x
5)))
111 ;; A meaningful NAMED-BINOP-P is defined.
112 (assert (named-binop-p named-binop
))
113 (assert (named-binop-p (copy-list named-binop
)))
114 (assert (not (named-binop-p (cons 11 named-binop
))))
115 (assert (not (named-binop-p (find-package :cl
)))))
121 (firetrucks 1 :type fixnum
)
123 (elevation 5128 :read-only t
))
124 (let ((town1 (make-town :area
0 :watertowers
0)))
125 (assert (town-p town1
))
126 (assert (not (town-p 1)))
127 (assert (eql (town-area town1
) 0))
128 (assert (eql (town-elevation town1
) 5128))
129 (assert (null (town-population town1
)))
130 (setf (town-population town1
) 99)
131 (assert (eql (town-population town1
) 99))
132 (let ((town2 (copy-town town1
)))
133 (dolist (slot-accessor-name '(town-area
138 (assert (eql (funcall slot-accessor-name town1
)
139 (funcall slot-accessor-name town2
))))
140 (assert (not (fboundp '(setf town-elevation
)))))) ; 'cause it's :READ-ONLY
143 (defstruct (clown (:conc-name bozo-
))
147 (let ((funny-clown (make-clown)))
148 (assert (eql (bozo-nose-color funny-clown
) 'red
)))
149 (defstruct (klown (:constructor make-up-klown
)
150 (:copier clone-klown
)
151 (:predicate is-a-bozo-p
))
155 (assert (is-a-bozo-p (make-up-klown)))
157 ;;;; systematically testing variants of DEFSTRUCT:
158 ;;;; * native, :TYPE LIST, and :TYPE VECTOR
160 ;;; FIXME: things to test:
161 ;;; * Slot readers work.
162 ;;; * Slot writers work.
163 ;;; * Predicates work.
165 ;;; FIXME: things that would be nice to test systematically someday:
166 ;;; * constructors (default, boa..)
168 ;;; * no type checks when (> SPEED SAFETY)
169 ;;; * Tests of inclusion would be good. (It's tested very lightly
170 ;;; above, and then tested a fair amount by the system compiling
173 (defun string+ (&rest rest
)
174 (apply #'concatenate
'string
175 (mapcar #'string rest
)))
176 (defun symbol+ (&rest rest
)
177 (values (intern (apply #'string
+ rest
))))
179 (defun accessor-name (conc-name slot-name
)
180 (symbol+ conc-name slot-name
))
182 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
183 ;;; to read and write a structure slot.
184 (defun read-slot-notinline (conc-name slot-name instance
)
185 (funcall (accessor-name conc-name slot-name
) instance
))
186 (defun write-slot-notinline (new-value conc-name slot-name instance
)
187 (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name
)))
190 ;;; Use inline expansions of slot accessors, if possible, to read and
191 ;;; write a structure slot.
192 (defun read-slot-inline (conc-name slot-name instance
)
193 (funcall (compile nil
195 (,(accessor-name conc-name slot-name
) instance
)))
197 (defun write-slot-inline (new-value conc-name slot-name instance
)
198 (funcall (compile nil
199 `(lambda (new-value instance
)
200 (setf (,(accessor-name conc-name slot-name
) instance
)
205 ;;; Read a structure slot, checking that the inline and out-of-line
206 ;;; accessors give the same result.
207 (defun read-slot (conc-name slot-name instance
)
208 (let ((inline-value (read-slot-inline conc-name slot-name instance
))
209 (notinline-value (read-slot-notinline conc-name slot-name instance
)))
210 (assert (eql inline-value notinline-value
))
213 ;;; Write a structure slot, using INLINEP argument to decide
214 ;;; on inlineness of accessor used.
215 (defun write-slot (new-value conc-name slot-name instance inlinep
)
217 (write-slot-inline new-value conc-name slot-name instance
)
218 (write-slot-notinline new-value conc-name slot-name instance
)))
220 ;;; bound during the tests so that we can get to it even if the
221 ;;; debugger is having a bad day
224 (declaim (optimize (debug 2)))
226 (defmacro test-variant
(defstructname &key colontype boa-constructor-p
)
229 (format t
"~&/beginning PROGN for COLONTYPE=~S~%" ',colontype
)
231 (defstruct (,defstructname
232 ,@(when colontype
`((:type
,colontype
)))
233 ,@(when boa-constructor-p
234 `((:constructor
,(symbol+ "CREATE-" defstructname
)
237 (optional-test 2 optional-test-p
)
240 (no-home-comment "Home package CL not provided.")
241 (comment (if home-p
"" no-home-comment
))
242 (refcount (if optional-test-p optional-test nil
))
246 ;; some ordinary tagged slots
248 (home nil
:type package
:read-only t
)
249 (comment "" :type simple-string
)
251 (weight 1.0 :type single-float
)
252 (hash 1 :type
(integer 1 #.
(* 3 most-positive-fixnum
)) :read-only t
)
253 ;; more ordinary tagged slots
254 (refcount 0 :type
(and unsigned-byte fixnum
)))
256 (format t
"~&/done with DEFSTRUCT~%")
258 (let* ((cn (string+ ',defstructname
"-")) ; conc-name
259 (ctor (symbol-function ',(symbol+ (if boa-constructor-p
263 (*instance
* (funcall ctor
264 ,@(unless boa-constructor-p
266 ,@(when boa-constructor-p
268 :home
(find-package :cl
)
269 :hash
(+ 14 most-positive-fixnum
)
270 ,@(unless boa-constructor-p
273 ;; Check that ctor set up slot values correctly.
274 (format t
"~&/checking constructed structure~%")
275 (assert (string= "some id" (read-slot cn
"ID" *instance
*)))
276 (assert (eql (find-package :cl
) (read-slot cn
"HOME" *instance
*)))
277 (assert (string= "" (read-slot cn
"COMMENT" *instance
*)))
278 (assert (= 1.0 (read-slot cn
"WEIGHT" *instance
*)))
279 (assert (eql (+ 14 most-positive-fixnum
)
280 (read-slot cn
"HASH" *instance
*)))
281 (assert (= 1 (read-slot cn
"REFCOUNT" *instance
*)))
283 ;; There should be no writers for read-only slots.
284 (format t
"~&/checking no read-only writers~%")
285 (assert (not (fboundp `(setf ,(symbol+ cn
"HOME")))))
286 (assert (not (fboundp `(setf ,(symbol+ cn
"HASH")))))
287 ;; (Read-only slot values are checked in the loop below.)
289 (dolist (inlinep '(t nil
))
290 (format t
"~&/doing INLINEP=~S~%" inlinep
)
291 ;; Fiddle with writable slot values.
292 (let ((new-id (format nil
"~S" (random 100)))
293 (new-comment (format nil
"~X" (random 5555)))
294 (new-weight (random 10.0)))
295 (write-slot new-id cn
"ID" *instance
* inlinep
)
296 (write-slot new-comment cn
"COMMENT" *instance
* inlinep
)
297 (write-slot new-weight cn
"WEIGHT" *instance
* inlinep
)
298 (assert (eql new-id
(read-slot cn
"ID" *instance
*)))
299 (assert (eql new-comment
(read-slot cn
"COMMENT" *instance
*)))
300 ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
301 ;; (error "WEIGHT mismatch: ~S vs. ~S"
302 ;; new-weight (read-slot cn "WEIGHT" *instance*)))
303 (assert (eql new-weight
(read-slot cn
"WEIGHT" *instance
*)))))
304 (format t
"~&/done with INLINEP loop~%")
306 ;; :TYPE FOO objects don't go in the Lisp type system, so we
307 ;; can't test TYPEP stuff for them.
309 ;; FIXME: However, when they're named, they do define
310 ;; predicate functions, and we could test those.
312 `(;; Fiddle with predicate function.
313 (let ((pred-name (symbol+ ',defstructname
"-P")))
314 (format t
"~&/doing tests on PRED-NAME=~S~%" pred-name
)
315 (assert (funcall pred-name
*instance
*))
316 (assert (not (funcall pred-name
14)))
317 (assert (not (funcall pred-name
"test")))
318 (assert (not (funcall pred-name
(make-hash-table))))
320 (compile nil
`(lambda (x) (,pred-name x
)))))
321 (format t
"~&/doing COMPILED-PRED tests~%")
322 (assert (funcall compiled-pred
*instance
*))
323 (assert (not (funcall compiled-pred
14)))
324 (assert (not (funcall compiled-pred
#()))))
325 ;; Fiddle with TYPEP.
326 (format t
"~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype
)
327 (assert (typep *instance
* ',defstructname
))
328 (assert (not (typep 0 ',defstructname
)))
329 (assert (funcall (symbol+ "TYPEP") *instance
* ',defstructname
))
330 (assert (not (funcall (symbol+ "TYPEP") nil
',defstructname
)))
331 (let* ((typename ',defstructname
)
333 (compile nil
`(lambda (x) (typep x
',typename
)))))
334 (assert (funcall compiled-typep
*instance
*))
335 (assert (not (funcall compiled-typep nil
))))))))
337 (format t
"~&/done with PROGN for COLONTYPE=~S~%" ',colontype
)))
339 (test-variant vanilla-struct
)
340 (test-variant vector-struct
:colontype vector
)
341 (test-variant list-struct
:colontype list
)
342 (test-variant vanilla-struct
:boa-constructor-p t
)
343 (test-variant vector-struct
:colontype vector
:boa-constructor-p t
)
344 (test-variant list-struct
:colontype list
:boa-constructor-p t
)
347 ;;;; testing raw slots harder
349 ;;;; The offsets of raw slots need to be rescaled during the punning
350 ;;;; process which is used to access them. That seems like a good
351 ;;;; place for errors to lurk, so we'll try hunting for them by
352 ;;;; verifying that all the raw slot data gets written successfully
353 ;;;; into the object, can be copied with the object, and can then be
354 ;;;; read back out (with none of it ending up bogusly outside the
355 ;;;; object, so that it couldn't be copied, or bogusly overwriting
356 ;;;; some other raw slot).
359 (a (expt 2 30) :type
(unsigned-byte #.sb-vm
:n-word-bits
))
360 (b 0.1 :type single-float
)
361 (c 0.2d0
:type double-float
)
362 (d #c
(0.3
0.3) :type
(complex single-float
))
363 unraw-slot-just-for-variety
364 (e #c
(0.4d0
0.4d0
) :type
(complex double-float
))
365 (aa (expt 2 30) :type
(unsigned-byte #.sb-vm
:n-word-bits
))
366 (bb 0.1 :type single-float
)
367 (cc 0.2d0
:type double-float
)
368 (dd #c
(0.3
0.3) :type
(complex single-float
))
369 (ee #c
(0.4d0
0.4d0
) :type
(complex double-float
)))
371 (defvar *manyraw
* (make-manyraw))
373 (assert (eql (manyraw-a *manyraw
*) (expt 2 30)))
374 (assert (eql (manyraw-b *manyraw
*) 0.1))
375 (assert (eql (manyraw-c *manyraw
*) 0.2d0
))
376 (assert (eql (manyraw-d *manyraw
*) #c
(0.3
0.3)))
377 (assert (eql (manyraw-e *manyraw
*) #c
(0.4d0
0.4d0
)))
378 (assert (eql (manyraw-aa *manyraw
*) (expt 2 30)))
379 (assert (eql (manyraw-bb *manyraw
*) 0.1))
380 (assert (eql (manyraw-cc *manyraw
*) 0.2d0
))
381 (assert (eql (manyraw-dd *manyraw
*) #c
(0.3
0.3)))
382 (assert (eql (manyraw-ee *manyraw
*) #c
(0.4d0
0.4d0
)))
384 (setf (manyraw-aa *manyraw
*) (expt 2 31)
385 (manyraw-bb *manyraw
*) 0.11
386 (manyraw-cc *manyraw
*) 0.22d0
387 (manyraw-dd *manyraw
*) #c
(0.33
0.33)
388 (manyraw-ee *manyraw
*) #c
(0.44d0
0.44d0
))
390 (let ((copy (copy-manyraw *manyraw
*)))
391 (assert (eql (manyraw-a copy
) (expt 2 30)))
392 (assert (eql (manyraw-b copy
) 0.1))
393 (assert (eql (manyraw-c copy
) 0.2d0
))
394 (assert (eql (manyraw-d copy
) #c
(0.3
0.3)))
395 (assert (eql (manyraw-e copy
) #c
(0.4d0
0.4d0
)))
396 (assert (eql (manyraw-aa copy
) (expt 2 31)))
397 (assert (eql (manyraw-bb copy
) 0.11))
398 (assert (eql (manyraw-cc copy
) 0.22d0
))
399 (assert (eql (manyraw-dd copy
) #c
(0.33
0.33)))
400 (assert (eql (manyraw-ee copy
) #c
(0.44d0
0.44d0
))))
403 ;;;; Since GC treats raw slots specially now, let's try this with more objects
404 ;;;; and random values as a stress test.
408 (defconstant +n-manyraw
+ 10)
409 (defconstant +m-manyraw
+ 1000)
411 (defun check-manyraws (manyraws)
412 (assert (eql (length manyraws
) (* +n-manyraw
+ +m-manyraw
+)))
414 for m in
(reverse manyraws
)
417 ;; Compare the tagged reference values with raw reffer results.
418 (destructuring-bind (j a b c d e
)
419 (manyraw-unraw-slot-just-for-variety m
)
421 (assert (= (manyraw-a m
) a
))
422 (assert (= (manyraw-b m
) b
))
423 (assert (= (manyraw-c m
) c
))
424 (assert (= (manyraw-d m
) d
))
425 (assert (= (manyraw-e m
) e
)))
426 ;; Test the funny out-of-line OAOOM-style closures, too.
427 (mapcar (lambda (fn value
)
428 (assert (= (funcall fn m
) value
)))
434 (cdr (manyraw-unraw-slot-just-for-variety m
)))))
436 (defstruct (manyraw-subclass (:include manyraw
))
437 (stolperstein 0 :type
(unsigned-byte 32)))
439 ;;; create lots of manyraw objects, triggering GC every now and then
440 (dotimes (y +n-manyraw
+)
441 (dotimes (x +m-manyraw
+)
442 (let ((a (random (expt 2 32)))
443 (b (random most-positive-single-float
))
444 (c (random most-positive-double-float
))
446 (random most-positive-single-float
)
447 (random most-positive-single-float
)))
449 (random most-positive-double-float
)
450 (random most-positive-double-float
))))
451 (push (funcall (if (zerop (mod x
3))
452 #'make-manyraw-subclass
454 :unraw-slot-just-for-variety
455 (list (+ x
(* y
+m-manyraw
+)) a b c d e
)
464 (check-manyraws *manyraw
*)
466 ;;; try a full GC, too
468 (check-manyraws *manyraw
*)
470 ;;; fasl dumper and loader also have special handling of raw slots, so
471 ;;; dump all of them into a fasl
472 (defmethod make-load-form ((self manyraw
) &optional env
)
474 :sb-just-dump-it-normally
)
475 (with-open-file (s "tmp-defstruct.manyraw.lisp"
477 :if-exists
:supersede
)
478 (write-string "(defun dumped-manyraws () '#.*manyraw*)" s
))
479 (compile-file "tmp-defstruct.manyraw.lisp")
480 (delete-file "tmp-defstruct.manyraw.lisp")
482 ;;; nuke the objects and try another GC just to be extra careful
486 ;;; re-read the dumped structures and check them
487 (load "tmp-defstruct.manyraw.fasl")
488 (check-manyraws (dumped-manyraws))
491 ;;;; miscellaneous old bugs
493 (defstruct ya-struct
)
494 (when (ignore-errors (or (ya-struct-p) 12))
495 (error "YA-STRUCT-P of no arguments should signal an error."))
496 (when (ignore-errors (or (ya-struct-p 'too
'many
'arguments
) 12))
497 (error "YA-STRUCT-P of three arguments should signal an error."))
499 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
500 ;;; declared inside on the theory that slot types were already
501 ;;; checked, which bogusly suppressed unbound-variable and other
502 ;;; checks within the evaluation of initforms.
504 (defstruct (bug210a (:constructor bug210a
()))
508 ;;; Because of bug 210, this assertion used to fail.
509 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable
))
510 ;;; Even with bug 210, these assertions succeeded.
511 (assert (typep (nth-value 1 (ignore-errors *bug210
*)) 'unbound-variable
))
512 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable
))
514 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
515 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
516 ;;; setting up compiler-layout information would run before the
517 ;;; constructor function installing the layout was compiled. Make sure
518 ;;; that doesn't happen again.
519 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x
(y :not
)))
520 (assert (not (find-class 'foo-0-7-8-53 nil
)))
522 (assert (find-class 'foo-0-7-8-53 nil
))
523 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x
:s
)))
524 (assert (eq (foo-0-7-8-53-x foo-0-7-8-53
) :s
))
525 (assert (eq (foo-0-7-8-53-y foo-0-7-8-53
) :not
)))
527 ;;; tests of behaviour of colliding accessors.
528 (defstruct (bug127-foo (:conc-name bug127-baz-
)) a
)
529 (assert (= (bug127-baz-a (make-bug127-foo :a
1)) 1))
530 (defstruct (bug127-bar (:conc-name bug127-baz-
) (:include bug127-foo
)) b
)
531 (assert (= (bug127-baz-a (make-bug127-bar :a
1 :b
2)) 1))
532 (assert (= (bug127-baz-b (make-bug127-bar :a
1 :b
2)) 2))
533 (assert (= (bug127-baz-a (make-bug127-foo :a
1)) 1))
535 (defun bug127-flurble (x)
537 (defstruct bug127 flurble
)
538 (assert (= (bug127-flurble (make-bug127 :flurble
7)) 7))
540 (defstruct bug127-a b-c
)
541 (assert (= (bug127-a-b-c (make-bug127-a :b-c
9)) 9))
542 (defstruct (bug127-a-b (:include bug127-a
)) c
)
543 (assert (= (bug127-a-b-c (make-bug127-a :b-c
9)) 9))
544 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c
11 :c
13)) 11))
546 (defstruct (bug127-e (:conc-name bug127--
)) foo
)
547 (assert (= (bug127--foo (make-bug127-e :foo
3)) 3))
548 (defstruct (bug127-f (:conc-name bug127--
)) foo
)
549 (assert (= (bug127--foo (make-bug127-f :foo
3)) 3))
550 (assert (raises-error?
(bug127--foo (make-bug127-e :foo
3)) type-error
))
552 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
554 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
556 (defstruct (conc-name-syntax :conc-name
) a-conc-name-slot
)
557 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot
'y
))
559 ;;; and further :CONC-NAME NIL was being wrongly treated:
560 (defpackage "DEFSTRUCT-TEST-SCRATCH")
561 (defstruct (conc-name-nil :conc-name
)
562 defstruct-test-scratch
::conc-name-nil-slot
)
563 (assert (= (defstruct-test-scratch::conc-name-nil-slot
564 (make-conc-name-nil :conc-name-nil-slot
1)) 1))
565 (assert (raises-error?
(conc-name-nil-slot (make-conc-name-nil))
568 ;;; The named/typed predicates were a little fragile, in that they
569 ;;; could throw errors on innocuous input:
570 (defstruct (list-struct (:type list
) :named
) a-slot
)
571 (assert (list-struct-p (make-list-struct)))
572 (assert (not (list-struct-p nil
)))
573 (assert (not (list-struct-p 1)))
574 (defstruct (offset-list-struct (:type list
) :named
(:initial-offset
1)) a-slot
)
575 (assert (offset-list-struct-p (make-offset-list-struct)))
576 (assert (not (offset-list-struct-p nil
)))
577 (assert (not (offset-list-struct-p 1)))
578 (assert (not (offset-list-struct-p '(offset-list-struct))))
579 (assert (not (offset-list-struct-p '(offset-list-struct .
3))))
580 (defstruct (vector-struct (:type vector
) :named
) a-slot
)
581 (assert (vector-struct-p (make-vector-struct)))
582 (assert (not (vector-struct-p nil
)))
583 (assert (not (vector-struct-p #())))
586 ;;; bug 3d: type safety with redefined type constraints on slots
587 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
590 (let* ((base-name (intern (format nil
"bug3d-~A" type
)))
591 (up-name (intern (format nil
"~A-up" base-name
)))
592 (accessor (intern (format nil
"~A-X" base-name
)))
593 (up-accessor (intern (format nil
"~A-X" up-name
)))
594 (type-options (when type
`((:type
,type
)))))
596 (defstruct (,base-name
,@type-options
)
598 (defstruct (,up-name
(:include
,base-name
599 (x "x" :type simple-string
)
600 (y "y" :type simple-string
))
602 (let ((ob (,(intern (format nil
"MAKE-~A" up-name
)))))
603 (setf (,accessor ob
) 0)
604 (loop for decl in
'(inline notinline
)
605 for fun
= `(lambda (s)
606 (declare (optimize (safety 3))
607 (,decl
,',up-accessor
))
609 do
(assert (raises-error?
(funcall (compile nil fun
) ob
)
615 (let* ((name (gensym))
616 (form `(defstruct ,name
617 (x nil
:type
(or null
(function (integer)
618 (values number
&optional foo
)))))))
619 (eval (copy-tree form
))
620 (eval (copy-tree form
)))
622 ;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
623 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
625 (defstruct (bug-332a (:type list
) (:initial-offset
5) :named
))
626 (defstruct (bug-332b (:type list
) (:initial-offset
2) :named
(:include bug-332a
)))
627 (assert (not (bug-332b-p (list* nil nil nil nil nil
'foo73 nil
'tail
))))
628 (assert (not (bug-332b-p 873257)))
629 (assert (not (bug-332b-p '(1 2 3 4 5 x
1 2 bug-332a
))))
630 (assert (bug-332b-p '(1 2 3 4 5 x
1 2 bug-332b
)))
632 ;;; Similar test for vectors, just for good measure.
633 (defstruct (bug-332a-aux (:type vector
)
634 (:initial-offset
5) :named
))
635 (defstruct (bug-332b-aux (:type vector
)
636 (:initial-offset
2) :named
637 (:include bug-332a-aux
)))
638 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x
1 premature-end
))))
639 (assert (not (bug-332b-aux-p 873257)))
640 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x
1 2 bug-332a-aux
))))
641 (assert (bug-332b-aux-p #(1 2 3 4 5 x
1 2 bug-332b-aux
)))
643 ;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
644 ;;; slot accessors signalled a condition at macroexpansion time, not
645 ;;; when the code was actually compiled or loaded.
646 (let ((defstruct-form '(defstruct bug-in-0-8-11-8 x
)))
647 (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
648 (handler-case (macroexpand defstruct-form
)
650 (error "shouldn't warn just from macroexpansion here"))))
652 ;;; bug 318 symptom no 1. (rest not fixed yet)
654 (handler-bind ((error (lambda (c)
655 ;; Used to cause stack-exhaustion
656 (unless (typep c
'storage-condition
)
660 (setf (find-class 'foo
) nil
)
661 (defstruct foo slot-1
)))))
663 ;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
665 (defstruct bug-348 x
)
667 (assert (eql -
1 (let ((i (eval '-
2))
669 (funcall #'(setf bug-348-x
)
671 (aref (vector x
) (incf i
)))
674 ;;; obsolete instance trapping
676 ;;; FIXME: Both error conditions below should possibly be instances
677 ;;; of the same class. (Putting this FIXME here, since this is the only
678 ;;; place where they appear together.)
680 (with-test (:name obsolete-defstruct
/print-object
)
681 (eval '(defstruct born-to-change
))
682 (let ((x (make-born-to-change)))
683 (handler-bind ((error 'continue
))
684 (eval '(defstruct born-to-change slot
)))
688 (sb-pcl::obsolete-structure
()
691 (with-test (:name obsolete-defstruct
/typep
)
692 (eval '(defstruct born-to-change-2
))
693 (let ((x (make-born-to-change-2)))
694 (handler-bind ((error 'continue
))
695 (eval '(defstruct born-to-change-2 slot
)))
698 (typep x
(find-class 'standard-class
))
699 (sb-kernel:layout-invalid
()
702 ;; EQUALP didn't work for structures with float slots (reported by
703 ;; Vjacheslav Fyodorov).
704 (defstruct raw-slot-equalp-bug
705 (b 0s0
:type single-float
)
707 (a 0d0
:type double-float
))
709 (with-test (:name raw-slot-equalp
)
710 (assert (equalp (make-raw-slot-equalp-bug :a
1d0
:b
2s0
)
711 (make-raw-slot-equalp-bug :a
1d0
:b
2s0
)))
712 (assert (equalp (make-raw-slot-equalp-bug :a
1d0
:b
0s0
)
713 (make-raw-slot-equalp-bug :a
1d0
:b -
0s0
)))
714 (assert (not (equalp (make-raw-slot-equalp-bug :a
1d0
:b
2s0
)
715 (make-raw-slot-equalp-bug :a
1d0
:b
3s0
))))
716 (assert (not (equalp (make-raw-slot-equalp-bug :a
1d0
:b
2s0
)
717 (make-raw-slot-equalp-bug :a
2d0
:b
2s0
)))))
719 ;;; Check that all slot types (non-raw and raw) can be initialized with
720 ;;; constant arguments.
721 (defstruct constant-arg-inits
724 (c 2 :type sb-vm
:word
)
725 (d 3.0 :type single-float
)
726 (e 4.0d0
:type double-float
)
727 (f #c
(5.0
5.0) :type
(complex single-float
))
728 (g #c
(6.0d0
6.0d0
) :type
(complex double-float
)))
729 (defun test-constant-arg-inits ()
730 (let ((foo (make-constant-arg-inits)))
731 (declare (dynamic-extent foo
))
732 (assert (eql 42 (constant-arg-inits-a foo
)))
733 (assert (eql 1 (constant-arg-inits-b foo
)))
734 (assert (eql 2 (constant-arg-inits-c foo
)))
735 (assert (eql 3.0 (constant-arg-inits-d foo
)))
736 (assert (eql 4.0d0
(constant-arg-inits-e foo
)))
737 (assert (eql #c
(5.0
5.0) (constant-arg-inits-f foo
)))
738 (assert (eql #c
(6.0d0
6.0d0
) (constant-arg-inits-g foo
)))))
739 (make-constant-arg-inits)