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 (declaim (optimize (debug 2)))
221 (defmacro test-variant (defstructname &key colontype boa-constructor-p)
224 (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
226 (defstruct (,defstructname
227 ,@(when colontype `((:type ,colontype)))
228 ,@(when boa-constructor-p
229 `((:constructor ,(symbol+ "CREATE-" defstructname)
232 (optional-test 2 optional-test-p)
235 (no-home-comment "Home package CL not provided.")
236 (comment (if home-p "" no-home-comment))
237 (refcount (if optional-test-p optional-test nil))
241 ;; some ordinary tagged slots
243 (home nil :type package :read-only t)
244 (comment "" :type simple-string)
246 (weight 1.0 :type single-float)
247 (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
248 ;; more ordinary tagged slots
249 (refcount 0 :type (and unsigned-byte fixnum)))
251 (format t "~&/done with DEFSTRUCT~%")
253 (let* ((cn (string+ ',defstructname "-")) ; conc-name
254 (ctor (symbol-function ',(symbol+ (if boa-constructor-p
258 (*instance* (funcall ctor
259 ,@(unless boa-constructor-p
261 ,@(when boa-constructor-p
263 :home (find-package :cl)
264 :hash (+ 14 most-positive-fixnum)
265 ,@(unless boa-constructor-p
268 ;; Check that ctor set up slot values correctly.
269 (format t "~&/checking constructed structure~%")
270 (assert (string= "some id" (read-slot cn "ID" *instance*)))
271 (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
272 (assert (string= "" (read-slot cn "COMMENT" *instance*)))
273 (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
274 (assert (eql (+ 14 most-positive-fixnum)
275 (read-slot cn "HASH" *instance*)))
276 (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
278 ;; There should be no writers for read-only slots.
279 (format t "~&/checking no read-only writers~%")
280 (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
281 (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
282 ;; (Read-only slot values are checked in the loop below.)
284 (dolist (inlinep '(t nil))
285 (format t "~&/doing INLINEP=~S~%" inlinep)
286 ;; Fiddle with writable slot values.
287 (let ((new-id (format nil "~S" (random 100)))
288 (new-comment (format nil "~X" (random 5555)))
289 (new-weight (random 10.0)))
290 (write-slot new-id cn "ID" *instance* inlinep)
291 (write-slot new-comment cn "COMMENT" *instance* inlinep)
292 (write-slot new-weight cn "WEIGHT" *instance* inlinep)
293 (assert (eql new-id (read-slot cn "ID" *instance*)))
294 (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
295 ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
296 ;; (error "WEIGHT mismatch: ~S vs. ~S"
297 ;; new-weight (read-slot cn "WEIGHT" *instance*)))
298 (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
299 (format t "~&/done with INLINEP loop~%")
301 ;; :TYPE FOO objects don't go in the Lisp type system, so we
302 ;; can't test TYPEP stuff for them.
304 ;; FIXME: However, when they're named, they do define
305 ;; predicate functions, and we could test those.
307 `(;; Fiddle with predicate function.
308 (let ((pred-name (symbol+ ',defstructname "-P")))
309 (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
310 (assert (funcall pred-name *instance*))
311 (assert (not (funcall pred-name 14)))
312 (assert (not (funcall pred-name "test")))
313 (assert (not (funcall pred-name (make-hash-table))))
315 (compile nil `(lambda (x) (,pred-name x)))))
316 (format t "~&/doing COMPILED-PRED tests~%")
317 (assert (funcall compiled-pred *instance*))
318 (assert (not (funcall compiled-pred 14)))
319 (assert (not (funcall compiled-pred #()))))
320 ;; Fiddle with TYPEP.
321 (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
322 (assert (typep *instance* ',defstructname))
323 (assert (not (typep 0 ',defstructname)))
324 (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
325 (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
326 (let* ((typename ',defstructname)
328 (compile nil `(lambda (x) (typep x ',typename)))))
329 (assert (funcall compiled-typep *instance*))
330 (assert (not (funcall compiled-typep nil))))))))
332 (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
334 (test-variant vanilla-struct)
335 (test-variant vector-struct :colontype vector)
336 (test-variant list-struct :colontype list)
337 (test-variant vanilla-struct :boa-constructor-p t)
338 (test-variant vector-struct :colontype vector :boa-constructor-p t)
339 (test-variant list-struct :colontype list :boa-constructor-p t)
342 ;;;; testing raw slots harder
344 ;;;; The offsets of raw slots need to be rescaled during the punning
345 ;;;; process which is used to access them. That seems like a good
346 ;;;; place for errors to lurk, so we'll try hunting for them by
347 ;;;; verifying that all the raw slot data gets written successfully
348 ;;;; into the object, can be copied with the object, and can then be
349 ;;;; read back out (with none of it ending up bogusly outside the
350 ;;;; object, so that it couldn't be copied, or bogusly overwriting
351 ;;;; some other raw slot).
354 (a (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
355 (b 0.1 :type single-float)
356 (c 0.2d0 :type double-float)
357 (d #c(0.3 0.3) :type (complex single-float))
358 unraw-slot-just-for-variety
359 (e #c(0.4d0 0.4d0) :type (complex double-float))
360 (aa (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
361 (bb 0.1 :type single-float)
362 (cc 0.2d0 :type double-float)
363 (dd #c(0.3 0.3) :type (complex single-float))
364 (ee #c(0.4d0 0.4d0) :type (complex double-float)))
366 (defvar *manyraw* (make-manyraw))
368 (assert (eql (manyraw-a *manyraw*) (expt 2 30)))
369 (assert (eql (manyraw-b *manyraw*) 0.1))
370 (assert (eql (manyraw-c *manyraw*) 0.2d0))
371 (assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
372 (assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
373 (assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
374 (assert (eql (manyraw-bb *manyraw*) 0.1))
375 (assert (eql (manyraw-cc *manyraw*) 0.2d0))
376 (assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
377 (assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
379 (setf (manyraw-aa *manyraw*) (expt 2 31)
380 (manyraw-bb *manyraw*) 0.11
381 (manyraw-cc *manyraw*) 0.22d0
382 (manyraw-dd *manyraw*) #c(0.33 0.33)
383 (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
385 (let ((copy (copy-manyraw *manyraw*)))
386 (assert (eql (manyraw-a copy) (expt 2 30)))
387 (assert (eql (manyraw-b copy) 0.1))
388 (assert (eql (manyraw-c copy) 0.2d0))
389 (assert (eql (manyraw-d copy) #c(0.3 0.3)))
390 (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0)))
391 (assert (eql (manyraw-aa copy) (expt 2 31)))
392 (assert (eql (manyraw-bb copy) 0.11))
393 (assert (eql (manyraw-cc copy) 0.22d0))
394 (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
395 (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
398 ;;;; Since GC treats raw slots specially now, let's try this with more objects
399 ;;;; and random values as a stress test.
403 (defconstant +n-manyraw+ 10)
404 (defconstant +m-manyraw+ 1000)
406 (defun check-manyraws (manyraws)
407 (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+)))
409 for m in (reverse manyraws)
412 ;; Compare the tagged reference values with raw reffer results.
413 (destructuring-bind (j a b c d e)
414 (manyraw-unraw-slot-just-for-variety m)
416 (assert (= (manyraw-a m) a))
417 (assert (= (manyraw-b m) b))
418 (assert (= (manyraw-c m) c))
419 (assert (= (manyraw-d m) d))
420 (assert (= (manyraw-e m) e)))
421 ;; Test the funny out-of-line OAOOM-style closures, too.
422 (mapcar (lambda (fn value)
423 (assert (= (funcall fn m) value)))
429 (cdr (manyraw-unraw-slot-just-for-variety m)))))
431 (defstruct (manyraw-subclass (:include manyraw))
432 (stolperstein 0 :type (unsigned-byte 32)))
434 ;;; create lots of manyraw objects, triggering GC every now and then
435 (dotimes (y +n-manyraw+)
436 (dotimes (x +m-manyraw+)
437 (let ((a (random (expt 2 32)))
438 (b (random most-positive-single-float))
439 (c (random most-positive-double-float))
441 (random most-positive-single-float)
442 (random most-positive-single-float)))
444 (random most-positive-double-float)
445 (random most-positive-double-float))))
446 (push (funcall (if (zerop (mod x 3))
447 #'make-manyraw-subclass
449 :unraw-slot-just-for-variety
450 (list (+ x (* y +m-manyraw+)) a b c d e)
459 (check-manyraws *manyraw*)
461 ;;; try a full GC, too
463 (check-manyraws *manyraw*)
465 ;;; fasl dumper and loader also have special handling of raw slots, so
466 ;;; dump all of them into a fasl
467 (defmethod make-load-form ((self manyraw) &optional env)
469 :sb-just-dump-it-normally)
470 (with-open-file (s "tmp-defstruct.manyraw.lisp"
472 :if-exists :supersede)
473 (write-string "(defun dumped-manyraws () '#.*manyraw*)" s))
474 (compile-file "tmp-defstruct.manyraw.lisp")
475 (delete-file "tmp-defstruct.manyraw.lisp")
477 ;;; nuke the objects and try another GC just to be extra careful
481 ;;; re-read the dumped structures and check them
482 (load "tmp-defstruct.manyraw.fasl")
483 (check-manyraws (dumped-manyraws))
486 ;;;; miscellaneous old bugs
488 (defstruct ya-struct)
489 (when (ignore-errors (or (ya-struct-p) 12))
490 (error "YA-STRUCT-P of no arguments should signal an error."))
491 (when (ignore-errors (or (ya-struct-p 'too 'many 'arguments) 12))
492 (error "YA-STRUCT-P of three arguments should signal an error."))
494 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
495 ;;; declared inside on the theory that slot types were already
496 ;;; checked, which bogusly suppressed unbound-variable and other
497 ;;; checks within the evaluation of initforms.
499 (defstruct (bug210a (:constructor bug210a ()))
503 ;;; Because of bug 210, this assertion used to fail.
504 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable))
505 ;;; Even with bug 210, these assertions succeeded.
506 (assert (typep (nth-value 1 (ignore-errors *bug210*)) 'unbound-variable))
507 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable))
509 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
510 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
511 ;;; setting up compiler-layout information would run before the
512 ;;; constructor function installing the layout was compiled. Make sure
513 ;;; that doesn't happen again.
514 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x (y :not)))
515 (assert (not (find-class 'foo-0-7-8-53 nil)))
517 (assert (find-class 'foo-0-7-8-53 nil))
518 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x :s)))
519 (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
520 (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))
522 ;;; tests of behaviour of colliding accessors.
523 (defstruct (bug127-foo (:conc-name bug127-baz-)) a)
524 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
525 (defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
526 (assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
527 (assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
528 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
530 (defun bug127-flurble (x)
532 (defstruct bug127 flurble)
533 (assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
535 (defstruct bug127-a b-c)
536 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
537 (defstruct (bug127-a-b (:include bug127-a)) c)
538 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
539 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
541 (defstruct (bug127-e (:conc-name bug127--)) foo)
542 (assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
543 (defstruct (bug127-f (:conc-name bug127--)) foo)
544 (assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
545 (assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error))
547 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
549 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
551 (defstruct (conc-name-syntax :conc-name) a-conc-name-slot)
552 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y))
554 ;;; and further :CONC-NAME NIL was being wrongly treated:
555 (defpackage "DEFSTRUCT-TEST-SCRATCH")
556 (defstruct (conc-name-nil :conc-name)
557 defstruct-test-scratch::conc-name-nil-slot)
558 (assert (= (defstruct-test-scratch::conc-name-nil-slot
559 (make-conc-name-nil :conc-name-nil-slot 1)) 1))
560 (assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
563 ;;; The named/typed predicates were a little fragile, in that they
564 ;;; could throw errors on innocuous input:
565 (defstruct (list-struct (:type list) :named) a-slot)
566 (assert (list-struct-p (make-list-struct)))
567 (assert (not (list-struct-p nil)))
568 (assert (not (list-struct-p 1)))
569 (defstruct (offset-list-struct (:type list) :named (:initial-offset 1)) a-slot)
570 (assert (offset-list-struct-p (make-offset-list-struct)))
571 (assert (not (offset-list-struct-p nil)))
572 (assert (not (offset-list-struct-p 1)))
573 (assert (not (offset-list-struct-p '(offset-list-struct))))
574 (assert (not (offset-list-struct-p '(offset-list-struct . 3))))
575 (defstruct (vector-struct (:type vector) :named) a-slot)
576 (assert (vector-struct-p (make-vector-struct)))
577 (assert (not (vector-struct-p nil)))
578 (assert (not (vector-struct-p #())))
580 ;;; bug 3d: type safety with redefined type constraints on slots
583 (let* ((base-name (intern (format nil "bug3d-~A" type)))
584 (up-name (intern (format nil "~A-up" base-name)))
585 (accessor (intern (format nil "~A-X" base-name)))
586 (up-accessor (intern (format nil "~A-X" up-name)))
587 (type-options (when type `((:type ,type)))))
589 (defstruct (,base-name ,@type-options)
591 (defstruct (,up-name (:include ,base-name
592 (x "x" :type simple-string)
593 (y "y" :type simple-string))
595 (let ((ob (,(intern (format nil "MAKE-~A" up-name)))))
596 (setf (,accessor ob) 0)
597 (loop for decl in '(inline notinline)
598 for fun = `(lambda (s)
599 (declare (optimize (safety 3))
600 (,decl ,',up-accessor))
602 do (assert (raises-error? (funcall (compile nil fun) ob)
608 (let* ((name (gensym))
609 (form `(defstruct ,name
610 (x nil :type (or null (function (integer)
611 (values number &optional foo)))))))
612 (eval (copy-tree form))
613 (eval (copy-tree form)))
615 ;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
616 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
618 (defstruct (bug-332a (:type list) (:initial-offset 5) :named))
619 (defstruct (bug-332b (:type list) (:initial-offset 2) :named (:include bug-332a)))
620 (assert (not (bug-332b-p (list* nil nil nil nil nil 'foo73 nil 'tail))))
621 (assert (not (bug-332b-p 873257)))
622 (assert (not (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332a))))
623 (assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b)))
625 ;;; Similar test for vectors, just for good measure.
626 (defstruct (bug-332a-aux (:type vector)
627 (:initial-offset 5) :named))
628 (defstruct (bug-332b-aux (:type vector)
629 (:initial-offset 2) :named
630 (:include bug-332a-aux)))
631 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end))))
632 (assert (not (bug-332b-aux-p 873257)))
633 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux))))
634 (assert (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332b-aux)))
636 ;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
637 ;;; slot accessors signalled a condition at macroexpansion time, not
638 ;;; when the code was actually compiled or loaded.
639 (let ((defstruct-form '(defstruct bug-in-0-8-11-8 x)))
640 (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
641 (handler-case (macroexpand defstruct-form)
643 (error "shouldn't warn just from macroexpansion here"))))
645 ;;; bug 318 symptom no 1. (rest not fixed yet)
647 (handler-bind ((error (lambda (c)
648 ;; Used to cause stack-exhaustion
649 (unless (typep c 'storage-condition)
653 (setf (find-class 'foo) nil)
654 (defstruct foo slot-1)))))
656 ;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
658 (defstruct bug-348 x)
660 (assert (eql -1 (let ((i (eval '-2))
662 (funcall #'(setf bug-348-x)
664 (aref (vector x) (incf i)))
668 (format t "~&/returning success~%")