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 (declaim (notinline opaque-identity
))
29 (defun opaque-identity (x) x
)
31 (defstruct (boa-saux (:constructor make-boa-saux
(&aux a
(b 3) (c))))
32 (a #\
! :type
(integer 1 2))
33 (b #\? :type
(integer 3 4))
34 (c #\
# :type
(integer 5 6)))
35 (let ((s (make-boa-saux)))
36 (locally (declare (optimize (safety 3))
38 (assert (raises-error?
(opaque-identity (boa-saux-a s
)) type-error
)))
39 (setf (boa-saux-a s
) 1)
40 (setf (boa-saux-c s
) 5)
41 (assert (eql (boa-saux-a s
) 1))
42 (assert (eql (boa-saux-b s
) 3))
43 (assert (eql (boa-saux-c s
) 5)))
44 ; these two checks should be
46 (let ((s (make-boa-saux)))
47 (locally (declare (optimize (safety 0))
49 (assert (eql (opaque-identity (boa-saux-a s
)) 0)))
50 (setf (boa-saux-a s
) 1)
51 (setf (boa-saux-c s
) 5)
52 (assert (eql (boa-saux-a s
) 1))
53 (assert (eql (boa-saux-b s
) 3))
54 (assert (eql (boa-saux-c s
) 5)))
56 (let ((s (make-boa-saux)))
57 (locally (declare (optimize (safety 3))
58 (notinline boa-saux-a
))
59 (assert (raises-error?
(opaque-identity (boa-saux-a s
)) type-error
)))
60 (setf (boa-saux-a s
) 1)
61 (setf (boa-saux-c s
) 5)
62 (assert (eql (boa-saux-a s
) 1))
63 (assert (eql (boa-saux-b s
) 3))
64 (assert (eql (boa-saux-c s
) 5)))
67 (defstruct (astronaut (:include person
)
70 (favorite-beverage 'tang
))
71 (let ((x (make-astronaut :name
"Buzz" :helmet-size
17.5)))
72 (assert (equal (person-name x
) "Buzz"))
73 (assert (equal (astro-name x
) "Buzz"))
74 (assert (eql (astro-favorite-beverage x
) 'tang
))
75 (assert (null (astro-age x
))))
76 (defstruct (ancient-astronaut (:include person
(age 77)))
78 (favorite-beverage 'tang
))
79 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name
"John")) 77))
81 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
82 (defstruct (binop (:type list
) :named
(:initial-offset
2))
83 (operator '?
:type symbol
)
86 (defstruct (annotated-binop (:type list
)
89 commutative associative identity
)
90 (assert (equal (make-annotated-binop :operator
'*
96 '(nil nil binop
* x
5 nil nil nil t t
1)))
98 ;;; effect of :NAMED on :TYPE
99 (defstruct (named-binop (:type list
) :named
)
100 (operator '?
:type symbol
)
103 (let ((named-binop (make-named-binop :operator
'+ :operand-1
'x
:operand-2
5)))
104 ;; The data representation is specified to look like this.
105 (assert (equal named-binop
'(named-binop + x
5)))
106 ;; A meaningful NAMED-BINOP-P is defined.
107 (assert (named-binop-p named-binop
))
108 (assert (named-binop-p (copy-list named-binop
)))
109 (assert (not (named-binop-p (cons 11 named-binop
))))
110 (assert (not (named-binop-p (find-package :cl
)))))
116 (firetrucks 1 :type fixnum
)
118 (elevation 5128 :read-only t
))
119 (let ((town1 (make-town :area
0 :watertowers
0)))
120 (assert (town-p town1
))
121 (assert (not (town-p 1)))
122 (assert (eql (town-area town1
) 0))
123 (assert (eql (town-elevation town1
) 5128))
124 (assert (null (town-population town1
)))
125 (setf (town-population town1
) 99)
126 (assert (eql (town-population town1
) 99))
127 (let ((town2 (copy-town town1
)))
128 (dolist (slot-accessor-name '(town-area
133 (assert (eql (funcall slot-accessor-name town1
)
134 (funcall slot-accessor-name town2
))))
135 (assert (not (fboundp '(setf town-elevation
)))))) ; 'cause it's :READ-ONLY
138 (defstruct (clown (:conc-name bozo-
))
142 (let ((funny-clown (make-clown)))
143 (assert (eql (bozo-nose-color funny-clown
) 'red
)))
144 (defstruct (klown (:constructor make-up-klown
)
145 (:copier clone-klown
)
146 (:predicate is-a-bozo-p
))
150 (assert (is-a-bozo-p (make-up-klown)))
152 ;;;; systematically testing variants of DEFSTRUCT:
153 ;;;; * native, :TYPE LIST, and :TYPE VECTOR
155 ;;; FIXME: things to test:
156 ;;; * Slot readers work.
157 ;;; * Slot writers work.
158 ;;; * Predicates work.
160 ;;; FIXME: things that would be nice to test systematically someday:
161 ;;; * constructors (default, boa..)
163 ;;; * no type checks when (> SPEED SAFETY)
164 ;;; * Tests of inclusion would be good. (It's tested very lightly
165 ;;; above, and then tested a fair amount by the system compiling
168 (defun string+ (&rest rest
)
169 (apply #'concatenate
'string
170 (mapcar #'string rest
)))
171 (defun symbol+ (&rest rest
)
172 (values (intern (apply #'string
+ rest
))))
174 (defun accessor-name (conc-name slot-name
)
175 (symbol+ conc-name slot-name
))
177 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
178 ;;; to read and write a structure slot.
179 (defun read-slot-notinline (conc-name slot-name instance
)
180 (funcall (accessor-name conc-name slot-name
) instance
))
181 (defun write-slot-notinline (new-value conc-name slot-name instance
)
182 (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name
)))
185 ;;; Use inline expansions of slot accessors, if possible, to read and
186 ;;; write a structure slot.
187 (defun read-slot-inline (conc-name slot-name instance
)
188 (funcall (compile nil
190 (,(accessor-name conc-name slot-name
) instance
)))
192 (defun write-slot-inline (new-value conc-name slot-name instance
)
193 (funcall (compile nil
194 `(lambda (new-value instance
)
195 (setf (,(accessor-name conc-name slot-name
) instance
)
200 ;;; Read a structure slot, checking that the inline and out-of-line
201 ;;; accessors give the same result.
202 (defun read-slot (conc-name slot-name instance
)
203 (let ((inline-value (read-slot-inline conc-name slot-name instance
))
204 (notinline-value (read-slot-notinline conc-name slot-name instance
)))
205 (assert (eql inline-value notinline-value
))
208 ;;; Write a structure slot, using INLINEP argument to decide
209 ;;; on inlineness of accessor used.
210 (defun write-slot (new-value conc-name slot-name instance inlinep
)
212 (write-slot-inline new-value conc-name slot-name instance
)
213 (write-slot-notinline new-value conc-name slot-name instance
)))
215 ;;; bound during the tests so that we can get to it even if the
216 ;;; debugger is having a bad day
219 (defmacro test-variant
(defstructname &key colontype boa-constructor-p
)
222 (format t
"~&/beginning PROGN for COLONTYPE=~S~%" ',colontype
)
224 (defstruct (,defstructname
225 ,@(when colontype
`((:type
,colontype
)))
226 ,@(when boa-constructor-p
227 `((:constructor
,(symbol+ "CREATE-" defstructname
)
230 (optional-test 2 optional-test-p
)
233 (no-home-comment "Home package CL not provided.")
234 (comment (if home-p
"" no-home-comment
))
235 (refcount (if optional-test-p optional-test nil
))
239 ;; some ordinary tagged slots
241 (home nil
:type package
:read-only t
)
242 (comment "" :type simple-string
)
244 (weight 1.0 :type single-float
)
245 (hash 1 :type
(integer 1 #.
(* 3 most-positive-fixnum
)) :read-only t
)
246 ;; more ordinary tagged slots
247 (refcount 0 :type
(and unsigned-byte fixnum
)))
249 (format t
"~&/done with DEFSTRUCT~%")
251 (let* ((cn (string+ ',defstructname
"-")) ; conc-name
252 (ctor (symbol-function ',(symbol+ (if boa-constructor-p
256 (*instance
* (funcall ctor
257 ,@(unless boa-constructor-p
259 ,@(when boa-constructor-p
261 :home
(find-package :cl
)
262 :hash
(+ 14 most-positive-fixnum
)
263 ,@(unless boa-constructor-p
266 ;; Check that ctor set up slot values correctly.
267 (format t
"~&/checking constructed structure~%")
268 (assert (string= "some id" (read-slot cn
"ID" *instance
*)))
269 (assert (eql (find-package :cl
) (read-slot cn
"HOME" *instance
*)))
270 (assert (string= "" (read-slot cn
"COMMENT" *instance
*)))
271 (assert (= 1.0 (read-slot cn
"WEIGHT" *instance
*)))
272 (assert (eql (+ 14 most-positive-fixnum
)
273 (read-slot cn
"HASH" *instance
*)))
274 (assert (= 1 (read-slot cn
"REFCOUNT" *instance
*)))
276 ;; There should be no writers for read-only slots.
277 (format t
"~&/checking no read-only writers~%")
278 (assert (not (fboundp `(setf ,(symbol+ cn
"HOME")))))
279 (assert (not (fboundp `(setf ,(symbol+ cn
"HASH")))))
280 ;; (Read-only slot values are checked in the loop below.)
282 (dolist (inlinep '(t nil
))
283 (format t
"~&/doing INLINEP=~S~%" inlinep
)
284 ;; Fiddle with writable slot values.
285 (let ((new-id (format nil
"~S" (random 100)))
286 (new-comment (format nil
"~X" (random 5555)))
287 (new-weight (random 10.0)))
288 (write-slot new-id cn
"ID" *instance
* inlinep
)
289 (write-slot new-comment cn
"COMMENT" *instance
* inlinep
)
290 (write-slot new-weight cn
"WEIGHT" *instance
* inlinep
)
291 (assert (eql new-id
(read-slot cn
"ID" *instance
*)))
292 (assert (eql new-comment
(read-slot cn
"COMMENT" *instance
*)))
293 ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
294 ;; (error "WEIGHT mismatch: ~S vs. ~S"
295 ;; new-weight (read-slot cn "WEIGHT" *instance*)))
296 (assert (eql new-weight
(read-slot cn
"WEIGHT" *instance
*)))))
297 (format t
"~&/done with INLINEP loop~%")
299 ;; :TYPE FOO objects don't go in the Lisp type system, so we
300 ;; can't test TYPEP stuff for them.
302 ;; FIXME: However, when they're named, they do define
303 ;; predicate functions, and we could test those.
305 `(;; Fiddle with predicate function.
306 (let ((pred-name (symbol+ ',defstructname
"-P")))
307 (format t
"~&/doing tests on PRED-NAME=~S~%" pred-name
)
308 (assert (funcall pred-name
*instance
*))
309 (assert (not (funcall pred-name
14)))
310 (assert (not (funcall pred-name
"test")))
311 (assert (not (funcall pred-name
(make-hash-table))))
313 (compile nil
`(lambda (x) (,pred-name x
)))))
314 (format t
"~&/doing COMPILED-PRED tests~%")
315 (assert (funcall compiled-pred
*instance
*))
316 (assert (not (funcall compiled-pred
14)))
317 (assert (not (funcall compiled-pred
#()))))
318 ;; Fiddle with TYPEP.
319 (format t
"~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype
)
320 (assert (typep *instance
* ',defstructname
))
321 (assert (not (typep 0 ',defstructname
)))
322 (assert (funcall (symbol+ "TYPEP") *instance
* ',defstructname
))
323 (assert (not (funcall (symbol+ "TYPEP") nil
',defstructname
)))
324 (let* ((typename ',defstructname
)
326 (compile nil
`(lambda (x) (typep x
',typename
)))))
327 (assert (funcall compiled-typep
*instance
*))
328 (assert (not (funcall compiled-typep nil
))))))))
330 (format t
"~&/done with PROGN for COLONTYPE=~S~%" ',colontype
)))
332 (test-variant vanilla-struct
)
333 (test-variant vector-struct
:colontype vector
)
334 (test-variant list-struct
:colontype list
)
335 (test-variant vanilla-struct
:boa-constructor-p t
)
336 (test-variant vector-struct
:colontype vector
:boa-constructor-p t
)
337 (test-variant list-struct
:colontype list
:boa-constructor-p t
)
340 ;;;; testing raw slots harder
342 ;;;; The offsets of raw slots need to be rescaled during the punning
343 ;;;; process which is used to access them. That seems like a good
344 ;;;; place for errors to lurk, so we'll try hunting for them by
345 ;;;; verifying that all the raw slot data gets written successfully
346 ;;;; into the object, can be copied with the object, and can then be
347 ;;;; read back out (with none of it ending up bogusly outside the
348 ;;;; object, so that it couldn't be copied, or bogusly overwriting
349 ;;;; some other raw slot).
352 (a (expt 2 30) :type
(unsigned-byte #.sb-vm
:n-word-bits
))
353 (b 0.1 :type single-float
)
354 (c 0.2d0
:type double-float
)
355 (d #c
(0.3
0.3) :type
(complex single-float
))
356 unraw-slot-just-for-variety
357 (e #c
(0.4d0
0.4d0
) :type
(complex double-float
))
358 (aa (expt 2 30) :type
(unsigned-byte #.sb-vm
:n-word-bits
))
359 (bb 0.1 :type single-float
)
360 (cc 0.2d0
:type double-float
)
361 (dd #c
(0.3
0.3) :type
(complex single-float
))
362 (ee #c
(0.4d0
0.4d0
) :type
(complex double-float
)))
364 (defvar *manyraw
* (make-manyraw))
366 (assert (eql (manyraw-a *manyraw
*) (expt 2 30)))
367 (assert (eql (manyraw-b *manyraw
*) 0.1))
368 (assert (eql (manyraw-c *manyraw
*) 0.2d0
))
369 (assert (eql (manyraw-d *manyraw
*) #c
(0.3
0.3)))
370 (assert (eql (manyraw-e *manyraw
*) #c
(0.4d0
0.4d0
)))
371 (assert (eql (manyraw-aa *manyraw
*) (expt 2 30)))
372 (assert (eql (manyraw-bb *manyraw
*) 0.1))
373 (assert (eql (manyraw-cc *manyraw
*) 0.2d0
))
374 (assert (eql (manyraw-dd *manyraw
*) #c
(0.3
0.3)))
375 (assert (eql (manyraw-ee *manyraw
*) #c
(0.4d0
0.4d0
)))
377 (setf (manyraw-aa *manyraw
*) (expt 2 31)
378 (manyraw-bb *manyraw
*) 0.11
379 (manyraw-cc *manyraw
*) 0.22d0
380 (manyraw-dd *manyraw
*) #c
(0.33
0.33)
381 (manyraw-ee *manyraw
*) #c
(0.44d0
0.44d0
))
383 (let ((copy (copy-manyraw *manyraw
*)))
384 (assert (eql (manyraw-a copy
) (expt 2 30)))
385 (assert (eql (manyraw-b copy
) 0.1))
386 (assert (eql (manyraw-c copy
) 0.2d0
))
387 (assert (eql (manyraw-d copy
) #c
(0.3
0.3)))
388 (assert (eql (manyraw-e copy
) #c
(0.4d0
0.4d0
)))
389 (assert (eql (manyraw-aa copy
) (expt 2 31)))
390 (assert (eql (manyraw-bb copy
) 0.11))
391 (assert (eql (manyraw-cc copy
) 0.22d0
))
392 (assert (eql (manyraw-dd copy
) #c
(0.33
0.33)))
393 (assert (eql (manyraw-ee copy
) #c
(0.44d0
0.44d0
))))
396 ;;;; Since GC treats raw slots specially now, let's try this with more objects
397 ;;;; and random values as a stress test.
401 (defconstant +n-manyraw
+ 10)
402 (defconstant +m-manyraw
+ 1000)
404 (defun check-manyraws (manyraws)
405 (assert (eql (length manyraws
) (* +n-manyraw
+ +m-manyraw
+)))
407 for m in
(reverse manyraws
)
410 ;; Compare the tagged reference values with raw reffer results.
411 (destructuring-bind (j a b c d e
)
412 (manyraw-unraw-slot-just-for-variety m
)
414 (assert (= (manyraw-a m
) a
))
415 (assert (= (manyraw-b m
) b
))
416 (assert (= (manyraw-c m
) c
))
417 (assert (= (manyraw-d m
) d
))
418 (assert (= (manyraw-e m
) e
)))
419 ;; Test the funny out-of-line OAOOM-style closures, too.
420 (mapcar (lambda (fn value
)
421 (assert (= (funcall fn m
) value
)))
427 (cdr (manyraw-unraw-slot-just-for-variety m
)))))
429 (defstruct (manyraw-subclass (:include manyraw
))
430 (stolperstein 0 :type
(unsigned-byte 32)))
432 ;;; create lots of manyraw objects, triggering GC every now and then
433 (dotimes (y +n-manyraw
+)
434 (dotimes (x +m-manyraw
+)
435 (let ((a (random (expt 2 32)))
436 (b (random most-positive-single-float
))
437 (c (random most-positive-double-float
))
439 (random most-positive-single-float
)
440 (random most-positive-single-float
)))
442 (random most-positive-double-float
)
443 (random most-positive-double-float
))))
444 (push (funcall (if (zerop (mod x
3))
445 #'make-manyraw-subclass
447 :unraw-slot-just-for-variety
448 (list (+ x
(* y
+m-manyraw
+)) a b c d e
)
457 (check-manyraws *manyraw
*)
459 ;;; try a full GC, too
461 (check-manyraws *manyraw
*)
463 ;;; fasl dumper and loader also have special handling of raw slots, so
464 ;;; dump all of them into a fasl
465 (defmethod make-load-form ((self manyraw
) &optional env
)
467 :sb-just-dump-it-normally
)
468 (with-open-file (s "tmp-defstruct.manyraw.lisp"
470 :if-exists
:supersede
)
471 (write-string "(defun dumped-manyraws () '#.*manyraw*)" s
))
472 (compile-file "tmp-defstruct.manyraw.lisp")
473 (delete-file "tmp-defstruct.manyraw.lisp")
475 ;;; nuke the objects and try another GC just to be extra careful
479 ;;; re-read the dumped structures and check them
480 (load "tmp-defstruct.manyraw.fasl")
481 (check-manyraws (dumped-manyraws))
484 ;;;; miscellaneous old bugs
486 (defstruct ya-struct
)
487 (when (ignore-errors (or (ya-struct-p) 12))
488 (error "YA-STRUCT-P of no arguments should signal an error."))
489 (when (ignore-errors (or (ya-struct-p 'too
'many
'arguments
) 12))
490 (error "YA-STRUCT-P of three arguments should signal an error."))
492 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
493 ;;; declared inside on the theory that slot types were already
494 ;;; checked, which bogusly suppressed unbound-variable and other
495 ;;; checks within the evaluation of initforms.
497 (defstruct (bug210a (:constructor bug210a
()))
501 ;;; Because of bug 210, this assertion used to fail.
502 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable
))
503 ;;; Even with bug 210, these assertions succeeded.
504 (assert (typep (nth-value 1 (ignore-errors *bug210
*)) 'unbound-variable
))
505 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable
))
507 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
508 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
509 ;;; setting up compiler-layout information would run before the
510 ;;; constructor function installing the layout was compiled. Make sure
511 ;;; that doesn't happen again.
512 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x
(y :not
)))
513 (assert (not (find-class 'foo-0-7-8-53 nil
)))
515 (assert (find-class 'foo-0-7-8-53 nil
))
516 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x
:s
)))
517 (assert (eq (foo-0-7-8-53-x foo-0-7-8-53
) :s
))
518 (assert (eq (foo-0-7-8-53-y foo-0-7-8-53
) :not
)))
520 ;;; tests of behaviour of colliding accessors.
521 (defstruct (bug127-foo (:conc-name bug127-baz-
)) a
)
522 (assert (= (bug127-baz-a (make-bug127-foo :a
1)) 1))
523 (defstruct (bug127-bar (:conc-name bug127-baz-
) (:include bug127-foo
)) b
)
524 (assert (= (bug127-baz-a (make-bug127-bar :a
1 :b
2)) 1))
525 (assert (= (bug127-baz-b (make-bug127-bar :a
1 :b
2)) 2))
526 (assert (= (bug127-baz-a (make-bug127-foo :a
1)) 1))
528 (defun bug127-flurble (x)
530 (defstruct bug127 flurble
)
531 (assert (= (bug127-flurble (make-bug127 :flurble
7)) 7))
533 (defstruct bug127-a b-c
)
534 (assert (= (bug127-a-b-c (make-bug127-a :b-c
9)) 9))
535 (defstruct (bug127-a-b (:include bug127-a
)) c
)
536 (assert (= (bug127-a-b-c (make-bug127-a :b-c
9)) 9))
537 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c
11 :c
13)) 11))
539 (defstruct (bug127-e (:conc-name bug127--
)) foo
)
540 (assert (= (bug127--foo (make-bug127-e :foo
3)) 3))
541 (defstruct (bug127-f (:conc-name bug127--
)) foo
)
542 (assert (= (bug127--foo (make-bug127-f :foo
3)) 3))
543 (assert (raises-error?
(bug127--foo (make-bug127-e :foo
3)) type-error
))
545 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
547 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
549 (defstruct (conc-name-syntax :conc-name
) a-conc-name-slot
)
550 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot
'y
))
552 ;;; and further :CONC-NAME NIL was being wrongly treated:
553 (defpackage "DEFSTRUCT-TEST-SCRATCH")
554 (defstruct (conc-name-nil :conc-name
)
555 defstruct-test-scratch
::conc-name-nil-slot
)
556 (assert (= (defstruct-test-scratch::conc-name-nil-slot
557 (make-conc-name-nil :conc-name-nil-slot
1)) 1))
558 (assert (raises-error?
(conc-name-nil-slot (make-conc-name-nil))
561 ;;; The named/typed predicates were a little fragile, in that they
562 ;;; could throw errors on innocuous input:
563 (defstruct (list-struct (:type list
) :named
) a-slot
)
564 (assert (list-struct-p (make-list-struct)))
565 (assert (not (list-struct-p nil
)))
566 (assert (not (list-struct-p 1)))
567 (defstruct (offset-list-struct (:type list
) :named
(:initial-offset
1)) a-slot
)
568 (assert (offset-list-struct-p (make-offset-list-struct)))
569 (assert (not (offset-list-struct-p nil
)))
570 (assert (not (offset-list-struct-p 1)))
571 (assert (not (offset-list-struct-p '(offset-list-struct))))
572 (assert (not (offset-list-struct-p '(offset-list-struct .
3))))
573 (defstruct (vector-struct (:type vector
) :named
) a-slot
)
574 (assert (vector-struct-p (make-vector-struct)))
575 (assert (not (vector-struct-p nil
)))
576 (assert (not (vector-struct-p #())))
578 ;;; bug 3d: type safety with redefined type constraints on slots
581 (let* ((base-name (intern (format nil
"bug3d-~A" type
)))
582 (up-name (intern (format nil
"~A-up" base-name
)))
583 (accessor (intern (format nil
"~A-X" base-name
)))
584 (up-accessor (intern (format nil
"~A-X" up-name
)))
585 (type-options (when type
`((:type
,type
)))))
587 (defstruct (,base-name
,@type-options
)
589 (defstruct (,up-name
(:include
,base-name
590 (x "x" :type simple-string
)
591 (y "y" :type simple-string
))
593 (let ((ob (,(intern (format nil
"MAKE-~A" up-name
)))))
594 (setf (,accessor ob
) 0)
595 (loop for decl in
'(inline notinline
)
596 for fun
= `(lambda (s)
597 (declare (optimize (safety 3))
598 (,decl
,',up-accessor
))
600 do
(assert (raises-error?
(funcall (compile nil fun
) ob
)
606 (let* ((name (gensym))
607 (form `(defstruct ,name
608 (x nil
:type
(or null
(function (integer)
609 (values number
&optional foo
)))))))
610 (eval (copy-tree form
))
611 (eval (copy-tree form
)))
613 ;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
614 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
616 (defstruct (bug-332a (:type list
) (:initial-offset
5) :named
))
617 (defstruct (bug-332b (:type list
) (:initial-offset
2) :named
(:include bug-332a
)))
618 (assert (not (bug-332b-p (list* nil nil nil nil nil
'foo73 nil
'tail
))))
619 (assert (not (bug-332b-p 873257)))
620 (assert (not (bug-332b-p '(1 2 3 4 5 x
1 2 bug-332a
))))
621 (assert (bug-332b-p '(1 2 3 4 5 x
1 2 bug-332b
)))
623 ;;; Similar test for vectors, just for good measure.
624 (defstruct (bug-332a-aux (:type vector
)
625 (:initial-offset
5) :named
))
626 (defstruct (bug-332b-aux (:type vector
)
627 (:initial-offset
2) :named
628 (:include bug-332a-aux
)))
629 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x
1 premature-end
))))
630 (assert (not (bug-332b-aux-p 873257)))
631 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x
1 2 bug-332a-aux
))))
632 (assert (bug-332b-aux-p #(1 2 3 4 5 x
1 2 bug-332b-aux
)))
634 ;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
635 ;;; slot accessors signalled a condition at macroexpansion time, not
636 ;;; when the code was actually compiled or loaded.
637 (let ((defstruct-form '(defstruct bug-in-0-8-11-8 x
)))
638 (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
639 (handler-case (macroexpand defstruct-form
)
641 (error "shouldn't warn just from macroexpansion here"))))
643 ;;; bug 318 symptom no 1. (rest not fixed yet)
645 (handler-bind ((error (lambda (c)
646 ;; Used to cause stack-exhaustion
647 (unless (typep c
'storege-condition
)
651 (setf (find-class 'foo
) nil
)
652 (defstruct foo slot-1
)))))
654 ;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
656 (defstruct bug-348 x
)
658 (assert (eql -
1 (let ((i (eval '-
2))
660 (funcall #'(setf bug-348-x
)
662 (aref (vector x
) (incf i
)))
666 (format t
"~&/returning success~%")
667 (quit :unix-status
104)