1.0.39: will be tagged as sbcl_1_0_39
[sbcl.git] / tests / defstruct.impure.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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
6 ;;;; from CMU CL.
7 ;;;;
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.
11
12 (load "assertoid.lisp")
13 (use-package "ASSERTOID")
14 \f
15 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
16
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
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)
27                        type-error))
28
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)
33
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))
40                     (inline boa-saux-a))
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
48                                         ; kept separated
49
50 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
51 (let ((s (make-boa-saux)))
52   (locally (declare (optimize (safety 0))
53                     (inline boa-saux-a))
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)))
60
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)))
70
71 ;;; basic inheritance
72 (defstruct (astronaut (:include person)
73                       (:conc-name astro-))
74   helmet-size
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)))
82   helmet-size
83   (favorite-beverage 'tang))
84 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77))
85
86 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
87 (defstruct (binop (:type list) :named (:initial-offset 2))
88   (operator '? :type symbol)
89   operand-1
90   operand-2)
91 (defstruct (annotated-binop (:type list)
92                             (:initial-offset 3)
93                             (:include binop))
94   commutative associative identity)
95 (assert (equal (make-annotated-binop :operator '*
96                                      :operand-1 'x
97                                      :operand-2 5
98                                      :commutative t
99                                      :associative t
100                                      :identity 1)
101                '(nil nil binop * x 5 nil nil nil t t 1)))
102
103 ;;; effect of :NAMED on :TYPE
104 (defstruct (named-binop (:type list) :named)
105   (operator '? :type symbol)
106   operand-1
107   operand-2)
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)))))
116
117 ;;; example 1
118 (defstruct town
119   area
120   watertowers
121   (firetrucks 1 :type fixnum)
122   population
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
134                                   town-watertowers
135                                   town-firetrucks
136                                   town-population
137                                   town-elevation))
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
141
142 ;;; example 2
143 (defstruct (clown (:conc-name bozo-))
144   (nose-color 'red)
145   frizzy-hair-p
146   polkadots)
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))
152   nose-color
153   frizzy-hair-p
154   polkadots)
155 (assert (is-a-bozo-p (make-up-klown)))
156 \f
157 ;;;; systematically testing variants of DEFSTRUCT:
158 ;;;;   * native, :TYPE LIST, and :TYPE VECTOR
159
160 ;;; FIXME: things to test:
161 ;;;   * Slot readers work.
162 ;;;   * Slot writers work.
163 ;;;   * Predicates work.
164
165 ;;; FIXME: things that would be nice to test systematically someday:
166 ;;;   * constructors (default, boa..)
167 ;;;   * copiers
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
171 ;;;     itself.)
172
173 (defun string+ (&rest rest)
174   (apply #'concatenate 'string
175          (mapcar #'string rest)))
176 (defun symbol+ (&rest rest)
177   (values (intern (apply #'string+ rest))))
178
179 (defun accessor-name (conc-name slot-name)
180   (symbol+ conc-name slot-name))
181
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)))
188            new-value instance))
189
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
194                     `(lambda (instance)
195                        (,(accessor-name conc-name slot-name) instance)))
196            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)
201                              new-value)))
202            new-value
203            instance))
204
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))
211     inline-value))
212
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)
216   (if inlinep
217       (write-slot-inline new-value conc-name slot-name instance)
218       (write-slot-notinline new-value conc-name slot-name instance)))
219
220 ;;; bound during the tests so that we can get to it even if the
221 ;;; debugger is having a bad day
222 (defvar *instance*)
223
224 (declaim (optimize (debug 2)))
225
226 (defmacro test-variant (defstructname &key colontype boa-constructor-p)
227   `(progn
228
229      (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
230
231      (defstruct (,defstructname
232                   ,@(when colontype `((:type ,colontype)))
233                   ,@(when boa-constructor-p
234                           `((:constructor ,(symbol+ "CREATE-" defstructname)
235                              (id
236                               &optional
237                               (optional-test 2 optional-test-p)
238                               &key
239                               (home nil home-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))
243                               hash
244                               weight)))))
245
246        ;; some ordinary tagged slots
247        id
248        (home nil :type package :read-only t)
249        (comment "" :type simple-string)
250        ;; some raw slots
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)))
255
256      (format t "~&/done with DEFSTRUCT~%")
257
258      (let* ((cn (string+ ',defstructname "-")) ; conc-name
259             (ctor (symbol-function ',(symbol+ (if boa-constructor-p
260                                                "CREATE-"
261                                                "MAKE-")
262                                              defstructname)))
263             (*instance* (funcall ctor
264                                  ,@(unless boa-constructor-p
265                                            `(:id)) "some id"
266                                  ,@(when boa-constructor-p
267                                          '(1))
268                                  :home (find-package :cl)
269                                  :hash (+ 14 most-positive-fixnum)
270                                  ,@(unless boa-constructor-p
271                                            `(:refcount 1)))))
272
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*)))
282
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.)
288
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~%")
305
306        ;; :TYPE FOO objects don't go in the Lisp type system, so we
307        ;; can't test TYPEP stuff for them.
308        ;;
309        ;; FIXME: However, when they're named, they do define
310        ;; predicate functions, and we could test those.
311        ,@(unless colontype
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))))
319                (let ((compiled-pred
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)
332                       (compiled-typep
333                        (compile nil `(lambda (x) (typep x ',typename)))))
334                  (assert (funcall compiled-typep *instance*))
335                  (assert (not (funcall compiled-typep nil))))))))
336
337      (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
338
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)
345
346 \f
347 ;;;; testing raw slots harder
348 ;;;;
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).
357
358 (defstruct manyraw
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)))
370
371 (defvar *manyraw* (make-manyraw))
372
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)))
383
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))
389
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))))
401
402 \f
403 ;;;; Since GC treats raw slots specially now, let's try this with more objects
404 ;;;; and random values as a stress test.
405
406 (setf *manyraw* nil)
407
408 (defconstant +n-manyraw+ 10)
409 (defconstant +m-manyraw+ 1000)
410
411 (defun check-manyraws (manyraws)
412   (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+)))
413   (loop
414       for m in (reverse manyraws)
415       for i from 0
416       do
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)
420           (assert (eql i j))
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)))
429                 (list #'manyraw-a
430                       #'manyraw-b
431                       #'manyraw-c
432                       #'manyraw-d
433                       #'manyraw-e)
434                 (cdr (manyraw-unraw-slot-just-for-variety m)))))
435
436 (defstruct (manyraw-subclass (:include manyraw))
437   (stolperstein 0 :type (unsigned-byte 32)))
438
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))
445           (d (complex
446               (random most-positive-single-float)
447               (random most-positive-single-float)))
448           (e (complex
449               (random most-positive-double-float)
450               (random most-positive-double-float))))
451       (push (funcall (if (zerop (mod x 3))
452                          #'make-manyraw-subclass
453                          #'make-manyraw)
454                      :unraw-slot-just-for-variety
455                      (list (+ x (* y +m-manyraw+)) a b c d e)
456                      :a a
457                      :b b
458                      :c c
459                      :d d
460                      :e e)
461             *manyraw*)))
462   (room)
463   (sb-ext:gc))
464 (check-manyraws *manyraw*)
465
466 ;;; try a full GC, too
467 (sb-ext:gc :full t)
468 (check-manyraws *manyraw*)
469
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)
473   self env
474   :sb-just-dump-it-normally)
475 (with-open-file (s "tmp-defstruct.manyraw.lisp"
476                  :direction :output
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")
481
482 ;;; nuke the objects and try another GC just to be extra careful
483 (setf *manyraw* nil)
484 (sb-ext:gc :full t)
485
486 ;;; re-read the dumped structures and check them
487 (load "tmp-defstruct.manyraw.fasl")
488 (check-manyraws (dumped-manyraws))
489
490 \f
491 ;;;; miscellaneous old bugs
492
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."))
498
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.
503 (defvar *bug210*)
504 (defstruct (bug210a (:constructor bug210a ()))
505   (slot *bug210*))
506 (defstruct bug210b
507   (slot *bug210*))
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))
513
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)))
521 (foo-0-7-8-53)
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)))
526 \f
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))
534
535 (defun bug127-flurble (x)
536   x)
537 (defstruct bug127 flurble)
538 (assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
539
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))
545
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))
551
552 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
553 \f
554 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
555 ;;; too fragile:
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))
558             '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))
566                        undefined-function))
567 \f
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 #())))
584 \f
585
586 ;;; bug 3d: type safety with redefined type constraints on slots
587 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
588 (macrolet
589     ((test (type)
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)))))
595          `(progn
596             (defstruct (,base-name ,@type-options)
597               x y)
598             (defstruct (,up-name (:include ,base-name
599                                            (x "x" :type simple-string)
600                                            (y "y" :type simple-string))
601                                  ,@type-options))
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))
608                                  (,',up-accessor s))
609                     do (assert (raises-error? (funcall (compile nil fun) ob)
610                                               type-error))))))))
611   (test nil)
612   (test list)
613   (test vector))
614
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)))
621
622 ;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
623 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
624 ;;; test suite.
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)))
631
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)))
642
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)
649     (warning (c)
650       (error "shouldn't warn just from macroexpansion here"))))
651
652 ;;; bug 318 symptom no 1. (rest not fixed yet)
653 (catch :ok
654   (handler-bind ((error (lambda (c)
655                           ;; Used to cause stack-exhaustion
656                           (unless (typep c 'storage-condition)
657                             (throw :ok t)))))
658     (eval '(progn
659             (defstruct foo a)
660             (setf (find-class 'foo) nil)
661             (defstruct foo slot-1)))))
662
663 ;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
664 ;;; Melis.
665 (defstruct bug-348 x)
666
667 (assert (eql -1 (let ((i (eval '-2))
668                       (x (make-bug-348)))
669                   (funcall #'(setf bug-348-x)
670                            (incf i)
671                            (aref (vector x) (incf i)))
672                   (bug-348-x x))))
673
674 ;;; obsolete instance trapping
675 ;;;
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.)
679
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)))
685     (assert (eq :error
686                 (handler-case
687                     (princ-to-string x)
688                   (sb-pcl::obsolete-structure ()
689                     :error))))))
690
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)))
696       (assert (eq :error2
697                   (handler-case
698                       (typep x (find-class 'standard-class))
699                     (sb-kernel:layout-invalid ()
700                       :error2))))))
701
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)
706   c
707   (a 0d0 :type double-float))
708
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)))))
718
719 ;;; Check that all slot types (non-raw and raw) can be initialized with
720 ;;; constant arguments.
721 (defstruct constant-arg-inits
722   (a 42 :type t)
723   (b 1 :type fixnum)
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)
740
741 ;;; bug reported by John Morrison, 2008-07-22 on sbcl-devel
742 (defstruct (raw-slot-struct-with-unknown-init (:constructor make-raw-slot-struct-with-unknown-init ()))
743  (x (#:unknown-function) :type double-float))
744 \f
745 ;;; Some checks for the behavior of incompatibly redefining structure
746 ;;; classes.  We don't actually check that our detection of
747 ;;; "incompatible" is comprehensive, only that if an incompatible
748 ;;; definition is processed, we do various things.
749 (defmacro with-files ((&rest vars) &body body)
750   "Evaluate BODY with VARS bound to a number of filenames, then
751 delete the files at the end."
752   (let* ((paths (loop for var in vars
753                       as index upfrom 0
754                       collect (make-pathname
755                                    :case :common
756                                    :name (format nil
757                                                  "DEFSTRUCT-REDEF-TEST-~D"
758                                                  index)
759                                    :type "LISP")))
760          (binding-spec (mapcar
761                         (lambda (var path) `(,var ,path)) vars paths)))
762     (labels ((frob (n)
763                `((unwind-protect
764                      (progn
765                        ,@(if (plusp n)
766                              (frob (1- n))
767                              body))
768                    (delete-file ,(elt paths n))))))
769       `(let ,binding-spec
770          ,@(frob (1- (length vars)))))))
771
772 (defun noclobber (pathspec &rest forms)
773   "Write FORMS to the file named by PATHSPEC, erroring if
774 PATHSPEC already names an existing file."
775   (with-open-file (*standard-output* pathspec :direction :output
776                                      :if-exists :error)
777     (print '(in-package "CL-USER"))
778     (mapc #'print forms)))
779
780 (defun compile-file-assert (file &optional (want-error-p t) (want-warning-p t))
781   "Compile FILE and assert some things about the results."
782   (multiple-value-bind (fasl errors-p warnings-p)
783       (compile-file file)
784     (assert fasl)
785     (assert (eq errors-p want-error-p))
786     (assert (eq warnings-p want-warning-p))
787     fasl))
788
789 (defun continue-from-incompatible-defstruct-error (error)
790   "Invoke the CONTINUE restart for an incompatible DEFSTRUCT
791 redefinition."
792   ;; FIXME: want distinct error type for incompatible defstruct.
793   (when (search "attempt to redefine" (simple-condition-format-control error))
794     (when (find-restart 'continue)
795       (invoke-restart 'continue))))
796
797 (defun recklessly-continue-from-incompatible-defstruct-error (error)
798   "Invoke the RECKLESSLY-CONTINUE restart for an incompatible DEFSTRUCT
799 redefinition."
800   ;; FIXME: want distinct error type for incompatible defstruct.
801   (when (search "attempt to redefine" (simple-condition-format-control error))
802     (when (find-restart 'sb-kernel::recklessly-continue)
803       (invoke-restart 'sb-kernel::recklessly-continue))))
804
805 (defun assert-is (predicate instance)
806   (assert (funcall predicate instance)))
807
808 (defun assert-invalid (predicate instance)
809   (assert (typep (nth-value 1 (ignore-errors (funcall predicate instance)))
810                  'sb-kernel::layout-invalid)))
811
812 ;; Don't try to understand this macro; just look at its expansion.
813 (defmacro with-defstruct-redefinition-test (name
814                                             (&rest defstruct-form-bindings)
815                                             (&rest path-form-specs)
816                                             handler-function
817                                             &body body)
818   (labels ((make-defstruct-form (&key class-name super-name slots)
819              (let* ((predicate-name
820                      (read-from-string (format nil "~A-p" class-name)))
821                     (constructor-name
822                      (read-from-string (format nil "make-~A" class-name))))
823                `(values
824                  '(defstruct (,class-name
825                              (:constructor ,constructor-name)
826                              ,@(when super-name
827                                  `((:include ,super-name))))
828                     ,@slots)
829                  ',constructor-name
830                  ',predicate-name)))
831            (frob (bindspecs classno)
832              (if bindspecs
833                  `((multiple-value-bind ,(first (first bindspecs))
834                        ,(apply #'make-defstruct-form (rest (first bindspecs)))
835                      (declare (ignorable ,@(first (first bindspecs))))
836                      ,@(frob (rest bindspecs) (1+ classno))))
837                  `((with-files ,(mapcar #'first path-form-specs)
838                      ,@(mapcar (lambda (path-form) `(noclobber ,@path-form))
839                                path-form-specs)
840                      (handler-bind
841                          ((simple-error ',handler-function))
842                        ,@body))))))
843     `(with-test (:name ,name)
844       ,(first (frob defstruct-form-bindings 0)))))
845
846 ;; When eyeballing these, it's helpful to see when various things are
847 ;; happening.
848 (setq *compile-verbose* t *load-verbose* t)
849 \f
850 ;;; Tests begin.
851 ;; Base case: recklessly-continue.
852 (with-defstruct-redefinition-test defstruct/recklessly
853     (((defstruct ctor pred) :class-name redef-test-1 :slots (a))
854      ((defstruct*) :class-name redef-test-1 :slots (a b)))
855     ((path1 defstruct)
856      (path2 defstruct*))
857     recklessly-continue-from-incompatible-defstruct-error
858   (load path1)
859   (let ((instance (funcall ctor)))
860     (load path2)
861     (assert-is pred instance)))
862
863 ;; Base case: continue (i.e., invalidate instances).
864 (with-defstruct-redefinition-test defstruct/continue
865     (((defstruct ctor pred) :class-name redef-test-2 :slots (a))
866      ((defstruct*) :class-name redef-test-2 :slots (a b)))
867     ((path1 defstruct)
868      (path2 defstruct*))
869     continue-from-incompatible-defstruct-error
870   (load path1)
871   (let ((instance (funcall ctor)))
872     (load path2)
873     (assert-invalid pred instance)))
874
875 ;; Compiling a file with an incompatible defstruct should emit a
876 ;; warning and an error, but the fasl should be loadable.
877 (with-defstruct-redefinition-test defstruct/compile-file-should-warn
878     (((defstruct) :class-name redef-test-3 :slots (a))
879      ((defstruct*) :class-name redef-test-3 :slots (a b)))
880     ((path1 defstruct)
881      (path2 defstruct*))
882     continue-from-incompatible-defstruct-error
883   (load path1)
884   (load (compile-file-assert path2)))
885
886 ;; After compiling a file with an incompatible DEFSTRUCT, load the
887 ;; fasl and ensure that an old instance remains valid.
888 (with-defstruct-redefinition-test defstruct/compile-file-reckless
889     (((defstruct ctor pred) :class-name redef-test-4 :slots (a))
890      ((defstruct*) :class-name redef-test-4 :slots (a b)))
891     ((path1 defstruct)
892      (path2 defstruct*))
893     recklessly-continue-from-incompatible-defstruct-error
894   (load path1)
895   (let ((instance (funcall ctor)))
896     (load (compile-file-assert path2))
897     (assert-is pred instance)))
898
899 ;; After compiling a file with an incompatible DEFSTRUCT, load the
900 ;; fasl and ensure that an old instance has become invalid.
901 (with-defstruct-redefinition-test defstruct/compile-file-continue
902     (((defstruct ctor pred) :class-name redef-test-5 :slots (a))
903      ((defstruct*) :class-name redef-test-5 :slots (a b)))
904     ((path1 defstruct)
905      (path2 defstruct*))
906     continue-from-incompatible-defstruct-error
907   (load path1)
908   (let ((instance (funcall ctor)))
909     (load (compile-file-assert path2))
910     (assert-invalid pred instance)))
911 \f
912 ;;; Subclasses.
913 ;; Ensure that recklessly continuing DT(expected)T to instances of
914 ;; subclasses.  (This is a case where recklessly continuing is
915 ;; actually dangerous, but we don't care.)
916 (with-defstruct-redefinition-test defstruct/subclass-reckless
917     (((defstruct ignore pred1) :class-name redef-test-6 :slots (a))
918      ((substruct ctor pred2) :class-name redef-test-6-sub
919                              :super-name redef-test-6 :slots (z))
920      ((defstruct*) :class-name redef-test-6 :slots (a b)))
921     ((path1 defstruct substruct)
922      (path2 defstruct* substruct))
923     recklessly-continue-from-incompatible-defstruct-error
924   (load path1)
925   (let ((instance (funcall ctor)))
926     (load (compile-file-assert path2))
927     (assert-is pred1 instance)
928     (assert-is pred2 instance)))
929
930 ;; Ensure that continuing invalidates instances of subclasses.
931 (with-defstruct-redefinition-test defstruct/subclass-continue
932     (((defstruct) :class-name redef-test-7 :slots (a))
933      ((substruct ctor pred) :class-name redef-test-7-sub
934                             :super-name redef-test-7 :slots (z))
935      ((defstruct*) :class-name redef-test-7 :slots (a b)))
936     ((path1 defstruct substruct)
937      (path2 defstruct* substruct))
938     continue-from-incompatible-defstruct-error
939   (load path1)
940   (let ((instance (funcall ctor)))
941     (load (compile-file-assert path2))
942     (assert-invalid pred instance)))
943
944 ;; Reclkessly continuing doesn't invalidate instances of subclasses.
945 (with-defstruct-redefinition-test defstruct/subclass-in-other-file-reckless
946     (((defstruct ignore pred1) :class-name redef-test-8 :slots (a))
947      ((substruct ctor pred2) :class-name redef-test-8-sub
948                              :super-name redef-test-8 :slots (z))
949      ((defstruct*) :class-name redef-test-8 :slots (a b)))
950     ((path1 defstruct)
951      (path2 substruct)
952      (path3 defstruct*))
953     recklessly-continue-from-incompatible-defstruct-error
954   (load path1)
955   (load path2)
956   (let ((instance (funcall ctor)))
957     (load (compile-file-assert path3))
958     (assert-is pred1 instance)
959     (assert-is pred2 instance)))
960
961 ;; This is an icky case: when a subclass is defined in a separate
962 ;; file, CONTINUE'ing from LOAD of a file containing an incompatible
963 ;; superclass definition leaves the predicates and accessors into the
964 ;; subclass in a bad way until the subclass form is evaluated.
965 (with-defstruct-redefinition-test defstruct/subclass-in-other-file-continue
966     (((defstruct ignore pred1) :class-name redef-test-9 :slots (a))
967      ((substruct ctor pred2) :class-name redef-test-9-sub
968                              :super-name redef-test-9 :slots (z))
969      ((defstruct*) :class-name redef-test-9 :slots (a b)))
970     ((path1 defstruct)
971      (path2 substruct)
972      (path3 defstruct*))
973     continue-from-incompatible-defstruct-error
974   (load path1)
975   (load path2)
976   (let ((instance (funcall ctor)))
977     (load (compile-file-assert path3))
978     ;; At this point, the instance of the subclass will not count as
979     ;; an instance of the superclass or of the subclass, but PRED2's
980     ;; predicate will error with "an obsolete structure accessor
981     ;; function was called".
982     (assert-invalid pred1 instance)
983     (format t "~&~A~%" (nth-value 1 (ignore-errors (funcall pred2 instance))))
984     ;; After loading PATH2, we'll get the desired LAYOUT-INVALID error.
985     (load path2)
986     (assert-invalid pred2 instance)))
987
988 ;; Some other subclass wrinkles have to do with splitting definitions
989 ;; accross files and compiling and loading things in a funny order.
990 (with-defstruct-redefinition-test
991     defstruct/subclass-in-other-file-funny-operation-order-continue
992     (((defstruct ignore pred1) :class-name redef-test-10 :slots (a))
993      ((substruct ctor pred2) :class-name redef-test-10-sub
994                              :super-name redef-test-10 :slots (z))
995      ((defstruct*) :class-name redef-test-10 :slots (a b)))
996     ((path1 defstruct)
997      (path2 substruct)
998      (path3 defstruct*))
999     continue-from-incompatible-defstruct-error
1000   (load path1)
1001   (load path2)
1002   (let ((instance (funcall ctor)))
1003     ;; First we clobber the compiler's layout for the superclass.
1004     (compile-file-assert path3)
1005     ;; Then we recompile the subclass definition (which generates a
1006     ;; warning about the compiled layout for the superclass being
1007     ;; incompatible with the loaded layout, because we haven't loaded
1008     ;; path3 since recompiling).
1009     (compile-file path2)
1010     ;; Ugh.  I don't want to think about loading these in the wrong
1011     ;; order.
1012     (load (compile-file-pathname path3))
1013     (load (compile-file-pathname path2))
1014     (assert-invalid pred1 instance)
1015     (assert-invalid pred2 instance)))
1016
1017 (with-defstruct-redefinition-test
1018     defstruct/subclass-in-other-file-funny-operation-order-continue
1019     (((defstruct ignore pred1) :class-name redef-test-11 :slots (a))
1020      ((substruct ctor pred2) :class-name redef-test-11-sub
1021                              :super-name redef-test-11 :slots (z))
1022      ((defstruct*) :class-name redef-test-11 :slots (a b)))
1023     ((path1 defstruct)
1024      (path2 substruct)
1025      (path3 defstruct*))
1026     continue-from-incompatible-defstruct-error
1027   (load path1)
1028   (load path2)
1029   (let ((instance (funcall ctor)))
1030     ;; This clobbers the compiler's layout for REDEF-TEST-11.
1031     (compile-file-assert path3)
1032     ;; This recompiles REDEF-TEST-11-SUB, using the new REDEF-TEST-11
1033     ;; compiler-layout.
1034     (load (compile-file-pathname path2))
1035     ;; Note that because we haven't loaded PATH3, we haven't clobbered
1036     ;; the class's layout REDEF-TEST-11, so REDEF-11's predicate will
1037     ;; still work.  That's probably bad.
1038     (assert-is pred1 instance)
1039     (assert-is pred2 instance)))
1040
1041 (with-test (:name :raw-slot/circle-subst)
1042   ;; CIRCLE-SUBSTS used %INSTANCE-REF on raw slots
1043   (multiple-value-bind (list n)
1044       (eval '(progn
1045               (defstruct raw-slot/circle-subst
1046                 (x 0.0 :type single-float))
1047               (read-from-string "((#1=#S(raw-slot/circle-subst :x 2.7158911)))")))
1048     (destructuring-bind ((struct)) list
1049       (assert (raw-slot/circle-subst-p struct))
1050       (assert (eql 2.7158911 (raw-slot/circle-subst-x struct)))
1051       (assert (eql 45 n)))))
1052
1053 (defstruct (bug-3b (:constructor make-bug-3b (&aux slot)))
1054   (slot nil :type string))
1055
1056 (with-test (:name :bug-3b)
1057   (handler-case
1058       (progn
1059         (bug-3b-slot (make-bug-3b))
1060         (error "fail"))
1061     (type-error (e)
1062       (assert (eq 'string (type-error-expected-type e)))
1063       (assert (zerop (type-error-datum e))))))
1064
1065 (with-test (:name defstruct-copier-typechecks-argument)
1066   (assert (not (raises-error? (copy-person (make-astronaut :name "Neil")))))
1067   (assert (raises-error? (copy-astronaut (make-person :name "Fred")))))
1068
1069 (with-test (:name :bug-528807)
1070   (let ((*evaluator-mode* :compile))
1071     (handler-bind ((style-warning #'error))
1072       (eval `(defstruct (bug-528807 (:constructor make-528807 (&aux x)))
1073                (x nil :type fixnum))))))