Really restore clisp cross-compilation.
[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 (load "compiler-test-util.lisp")
14 (use-package "ASSERTOID")
15 \f
16 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
17
18 ;;; Type mismatch of slot default init value isn't an error until the
19 ;;; default init value is actually used. (The justification is
20 ;;; somewhat bogus, but the requirement is clear.)
21 (defstruct person age (name 007 :type string)) ; not an error until 007 used
22 (make-person :name "James") ; not an error, 007 not used
23
24 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
25 (assert (raises-error? (make-person) type-error))
26 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
27 (assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
28                        type-error))
29
30 ;;; An &AUX variable in a boa-constructor without a default value
31 ;;; means "do not initialize slot" and does not cause type error
32 (declaim (notinline opaque-identity))
33 (defun opaque-identity (x) x)
34
35 (defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c))))
36     (a #\! :type (integer 1 2))
37     (b #\? :type (integer 3 4))
38     (c #\# :type (integer 5 6)))
39 (let ((s (make-boa-saux)))
40   (locally (declare (optimize (safety 3))
41                     (inline boa-saux-a))
42     (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error)))
43   (setf (boa-saux-a s) 1)
44   (setf (boa-saux-c s) 5)
45   (assert (eql (boa-saux-a s) 1))
46   (assert (eql (boa-saux-b s) 3))
47   (assert (eql (boa-saux-c s) 5)))
48                                         ; these two checks should be
49                                         ; kept separated
50
51 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
52 (let ((s (make-boa-saux)))
53   (locally (declare (optimize (safety 0))
54                     (inline boa-saux-a))
55     (assert (eql (opaque-identity (boa-saux-a s)) 0)))
56   (setf (boa-saux-a s) 1)
57   (setf (boa-saux-c s) 5)
58   (assert (eql (boa-saux-a s) 1))
59   (assert (eql (boa-saux-b s) 3))
60   (assert (eql (boa-saux-c s) 5)))
61
62 (let ((s (make-boa-saux)))
63   (locally (declare (optimize (safety 3))
64                     (notinline boa-saux-a))
65     (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error)))
66   (setf (boa-saux-a s) 1)
67   (setf (boa-saux-c s) 5)
68   (assert (eql (boa-saux-a s) 1))
69   (assert (eql (boa-saux-b s) 3))
70   (assert (eql (boa-saux-c s) 5)))
71
72 ;;; basic inheritance
73 (defstruct (astronaut (:include person)
74                       (:conc-name astro-))
75   helmet-size
76   (favorite-beverage 'tang))
77 (let ((x (make-astronaut :name "Buzz" :helmet-size 17.5)))
78   (assert (equal (person-name x) "Buzz"))
79   (assert (equal (astro-name x) "Buzz"))
80   (assert (eql (astro-favorite-beverage x) 'tang))
81   (assert (null (astro-age x))))
82 (defstruct (ancient-astronaut (:include person (age 77)))
83   helmet-size
84   (favorite-beverage 'tang))
85 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77))
86
87 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
88 (defstruct (binop (:type list) :named (:initial-offset 2))
89   (operator '? :type symbol)
90   operand-1
91   operand-2)
92 (defstruct (annotated-binop (:type list)
93                             (:initial-offset 3)
94                             (:include binop))
95   commutative associative identity)
96 (assert (equal (make-annotated-binop :operator '*
97                                      :operand-1 'x
98                                      :operand-2 5
99                                      :commutative t
100                                      :associative t
101                                      :identity 1)
102                '(nil nil binop * x 5 nil nil nil t t 1)))
103
104 ;;; effect of :NAMED on :TYPE
105 (defstruct (named-binop (:type list) :named)
106   (operator '? :type symbol)
107   operand-1
108   operand-2)
109 (let ((named-binop (make-named-binop :operator '+ :operand-1 'x :operand-2 5)))
110   ;; The data representation is specified to look like this.
111   (assert (equal named-binop '(named-binop + x 5)))
112   ;; A meaningful NAMED-BINOP-P is defined.
113   (assert (named-binop-p named-binop))
114   (assert (named-binop-p (copy-list named-binop)))
115   (assert (not (named-binop-p (cons 11 named-binop))))
116   (assert (not (named-binop-p (find-package :cl)))))
117
118 ;;; example 1
119 (defstruct town
120   area
121   watertowers
122   (firetrucks 1 :type fixnum)
123   population
124   (elevation 5128 :read-only t))
125 (let ((town1 (make-town :area 0 :watertowers 0)))
126   (assert (town-p town1))
127   (assert (not (town-p 1)))
128   (assert (eql (town-area town1) 0))
129   (assert (eql (town-elevation town1) 5128))
130   (assert (null (town-population town1)))
131   (setf (town-population town1) 99)
132   (assert (eql (town-population town1) 99))
133   (let ((town2 (copy-town town1)))
134     (dolist (slot-accessor-name '(town-area
135                                   town-watertowers
136                                   town-firetrucks
137                                   town-population
138                                   town-elevation))
139       (assert (eql (funcall slot-accessor-name town1)
140                    (funcall slot-accessor-name town2))))
141     (assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY
142
143 ;;; example 2
144 (defstruct (clown (:conc-name bozo-))
145   (nose-color 'red)
146   frizzy-hair-p
147   polkadots)
148 (let ((funny-clown (make-clown)))
149   (assert (eql (bozo-nose-color funny-clown) 'red)))
150 (defstruct (klown (:constructor make-up-klown)
151                   (:copier clone-klown)
152                   (:predicate is-a-bozo-p))
153   nose-color
154   frizzy-hair-p
155   polkadots)
156 (assert (is-a-bozo-p (make-up-klown)))
157 \f
158 ;;;; systematically testing variants of DEFSTRUCT:
159 ;;;;   * native, :TYPE LIST, and :TYPE VECTOR
160
161 ;;; FIXME: things to test:
162 ;;;   * Slot readers work.
163 ;;;   * Slot writers work.
164 ;;;   * Predicates work.
165
166 ;;; FIXME: things that would be nice to test systematically someday:
167 ;;;   * constructors (default, boa..)
168 ;;;   * copiers
169 ;;;   * no type checks when (> SPEED SAFETY)
170 ;;;   * Tests of inclusion would be good. (It's tested very lightly
171 ;;;     above, and then tested a fair amount by the system compiling
172 ;;;     itself.)
173
174 (defun string+ (&rest rest)
175   (apply #'concatenate 'string
176          (mapcar #'string rest)))
177 (defun symbol+ (&rest rest)
178   (values (intern (apply #'string+ rest))))
179
180 (defun accessor-name (conc-name slot-name)
181   (symbol+ conc-name slot-name))
182
183 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
184 ;;; to read and write a structure slot.
185 (defun read-slot-notinline (conc-name slot-name instance)
186   (funcall (accessor-name conc-name slot-name) instance))
187 (defun write-slot-notinline (new-value conc-name slot-name instance)
188   (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
189            new-value instance))
190
191 ;;; Use inline expansions of slot accessors, if possible, to read and
192 ;;; write a structure slot.
193 (defun read-slot-inline (conc-name slot-name instance)
194   (funcall (compile nil
195                     `(lambda (instance)
196                        (,(accessor-name conc-name slot-name) instance)))
197            instance))
198 (defun write-slot-inline (new-value conc-name slot-name instance)
199   (funcall (compile nil
200                     `(lambda (new-value instance)
201                        (setf (,(accessor-name conc-name slot-name) instance)
202                              new-value)))
203            new-value
204            instance))
205
206 ;;; Read a structure slot, checking that the inline and out-of-line
207 ;;; accessors give the same result.
208 (defun read-slot (conc-name slot-name instance)
209   (let ((inline-value (read-slot-inline conc-name slot-name instance))
210         (notinline-value (read-slot-notinline conc-name slot-name instance)))
211     (assert (eql inline-value notinline-value))
212     inline-value))
213
214 ;;; Write a structure slot, using INLINEP argument to decide
215 ;;; on inlineness of accessor used.
216 (defun write-slot (new-value conc-name slot-name instance inlinep)
217   (if inlinep
218       (write-slot-inline new-value conc-name slot-name instance)
219       (write-slot-notinline new-value conc-name slot-name instance)))
220
221 ;;; bound during the tests so that we can get to it even if the
222 ;;; debugger is having a bad day
223 (defvar *instance*)
224
225 (declaim (optimize (debug 2)))
226
227 (defmacro test-variant (defstructname &key colontype boa-constructor-p)
228   `(progn
229
230      (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
231
232      (defstruct (,defstructname
233                   ,@(when colontype `((:type ,colontype)))
234                   ,@(when boa-constructor-p
235                           `((:constructor ,(symbol+ "CREATE-" defstructname)
236                              (id
237                               &optional
238                               (optional-test 2 optional-test-p)
239                               &key
240                               (home nil home-p)
241                               (no-home-comment "Home package CL not provided.")
242                               (comment (if home-p "" no-home-comment))
243                               (refcount (if optional-test-p optional-test nil))
244                               hash
245                               weight)))))
246
247        ;; some ordinary tagged slots
248        id
249        (home nil :type package :read-only t)
250        (comment "" :type simple-string)
251        ;; some raw slots
252        (weight 1.0 :type single-float)
253        (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
254        ;; more ordinary tagged slots
255        (refcount 0 :type (and unsigned-byte fixnum)))
256
257      (format t "~&/done with DEFSTRUCT~%")
258
259      (let* ((cn (string+ ',defstructname "-")) ; conc-name
260             (ctor (symbol-function ',(symbol+ (if boa-constructor-p
261                                                "CREATE-"
262                                                "MAKE-")
263                                              defstructname)))
264             (*instance* (funcall ctor
265                                  ,@(unless boa-constructor-p
266                                            `(:id)) "some id"
267                                  ,@(when boa-constructor-p
268                                          '(1))
269                                  :home (find-package :cl)
270                                  :hash (+ 14 most-positive-fixnum)
271                                  ,@(unless boa-constructor-p
272                                            `(:refcount 1)))))
273
274        ;; Check that ctor set up slot values correctly.
275        (format t "~&/checking constructed structure~%")
276        (assert (string= "some id" (read-slot cn "ID" *instance*)))
277        (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
278        (assert (string= "" (read-slot cn "COMMENT" *instance*)))
279        (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
280        (assert (eql (+ 14 most-positive-fixnum)
281                     (read-slot cn "HASH" *instance*)))
282        (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
283
284        ;; There should be no writers for read-only slots.
285        (format t "~&/checking no read-only writers~%")
286        (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
287        (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
288        ;; (Read-only slot values are checked in the loop below.)
289
290        (dolist (inlinep '(t nil))
291          (format t "~&/doing INLINEP=~S~%" inlinep)
292          ;; Fiddle with writable slot values.
293          (let ((new-id (format nil "~S" (random 100)))
294                (new-comment (format nil "~X" (random 5555)))
295                (new-weight (random 10.0)))
296            (write-slot new-id cn "ID" *instance* inlinep)
297            (write-slot new-comment cn "COMMENT" *instance* inlinep)
298            (write-slot new-weight cn "WEIGHT" *instance* inlinep)
299            (assert (eql new-id (read-slot cn "ID" *instance*)))
300            (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
301            ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
302            ;;  (error "WEIGHT mismatch: ~S vs. ~S"
303            ;;         new-weight (read-slot cn "WEIGHT" *instance*)))
304            (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
305        (format t "~&/done with INLINEP loop~%")
306
307        ;; :TYPE FOO objects don't go in the Lisp type system, so we
308        ;; can't test TYPEP stuff for them.
309        ;;
310        ;; FIXME: However, when they're named, they do define
311        ;; predicate functions, and we could test those.
312        ,@(unless colontype
313            `(;; Fiddle with predicate function.
314              (let ((pred-name (symbol+ ',defstructname "-P")))
315                (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
316                (assert (funcall pred-name *instance*))
317                (assert (not (funcall pred-name 14)))
318                (assert (not (funcall pred-name "test")))
319                (assert (not (funcall pred-name (make-hash-table))))
320                (let ((compiled-pred
321                       (compile nil `(lambda (x) (,pred-name x)))))
322                  (format t "~&/doing COMPILED-PRED tests~%")
323                  (assert (funcall compiled-pred *instance*))
324                  (assert (not (funcall compiled-pred 14)))
325                  (assert (not (funcall compiled-pred #()))))
326                ;; Fiddle with TYPEP.
327                (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
328                (assert (typep *instance* ',defstructname))
329                (assert (not (typep 0 ',defstructname)))
330                (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
331                (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
332                (let* ((typename ',defstructname)
333                       (compiled-typep
334                        (compile nil `(lambda (x) (typep x ',typename)))))
335                  (assert (funcall compiled-typep *instance*))
336                  (assert (not (funcall compiled-typep nil))))))))
337
338      (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
339
340 (test-variant vanilla-struct)
341 (test-variant vector-struct :colontype vector)
342 (test-variant list-struct :colontype list)
343 (test-variant vanilla-struct :boa-constructor-p t)
344 (test-variant vector-struct :colontype vector :boa-constructor-p t)
345 (test-variant list-struct :colontype list :boa-constructor-p t)
346
347 \f
348 ;;;; testing raw slots harder
349 ;;;;
350 ;;;; The offsets of raw slots need to be rescaled during the punning
351 ;;;; process which is used to access them. That seems like a good
352 ;;;; place for errors to lurk, so we'll try hunting for them by
353 ;;;; verifying that all the raw slot data gets written successfully
354 ;;;; into the object, can be copied with the object, and can then be
355 ;;;; read back out (with none of it ending up bogusly outside the
356 ;;;; object, so that it couldn't be copied, or bogusly overwriting
357 ;;;; some other raw slot).
358
359 (defstruct manyraw
360   (a (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
361   (b 0.1 :type single-float)
362   (c 0.2d0 :type double-float)
363   (d #c(0.3 0.3) :type (complex single-float))
364   unraw-slot-just-for-variety
365   (e #c(0.4d0 0.4d0) :type (complex double-float))
366   (aa (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
367   (bb 0.1 :type single-float)
368   (cc 0.2d0 :type double-float)
369   (dd #c(0.3 0.3) :type (complex single-float))
370   (ee #c(0.4d0 0.4d0) :type (complex double-float)))
371
372 (defvar *manyraw* (make-manyraw))
373
374 (assert (eql (manyraw-a *manyraw*) (expt 2 30)))
375 (assert (eql (manyraw-b *manyraw*) 0.1))
376 (assert (eql (manyraw-c *manyraw*) 0.2d0))
377 (assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
378 (assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
379 (assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
380 (assert (eql (manyraw-bb *manyraw*) 0.1))
381 (assert (eql (manyraw-cc *manyraw*) 0.2d0))
382 (assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
383 (assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
384
385 (setf (manyraw-aa *manyraw*) (expt 2 31)
386       (manyraw-bb *manyraw*) 0.11
387       (manyraw-cc *manyraw*) 0.22d0
388       (manyraw-dd *manyraw*) #c(0.33 0.33)
389       (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
390
391 (let ((copy (copy-manyraw *manyraw*)))
392   (assert (eql (manyraw-a copy) (expt 2 30)))
393   (assert (eql (manyraw-b copy) 0.1))
394   (assert (eql (manyraw-c copy) 0.2d0))
395   (assert (eql (manyraw-d copy) #c(0.3 0.3)))
396   (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0)))
397   (assert (eql (manyraw-aa copy) (expt 2 31)))
398   (assert (eql (manyraw-bb copy) 0.11))
399   (assert (eql (manyraw-cc copy) 0.22d0))
400   (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
401   (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
402
403 \f
404 ;;;; Since GC treats raw slots specially now, let's try this with more objects
405 ;;;; and random values as a stress test.
406
407 (setf *manyraw* nil)
408
409 (defconstant +n-manyraw+ 10)
410 (defconstant +m-manyraw+ 1000)
411
412 (defun check-manyraws (manyraws)
413   (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+)))
414   (loop
415       for m in (reverse manyraws)
416       for i from 0
417       do
418         ;; Compare the tagged reference values with raw reffer results.
419         (destructuring-bind (j a b c d e)
420             (manyraw-unraw-slot-just-for-variety m)
421           (assert (eql i j))
422           (assert (= (manyraw-a m) a))
423           (assert (= (manyraw-b m) b))
424           (assert (= (manyraw-c m) c))
425           (assert (= (manyraw-d m) d))
426           (assert (= (manyraw-e m) e)))
427         ;; Test the funny out-of-line OAOOM-style closures, too.
428         (mapcar (lambda (fn value)
429                   (assert (= (funcall fn m) value)))
430                 (list #'manyraw-a
431                       #'manyraw-b
432                       #'manyraw-c
433                       #'manyraw-d
434                       #'manyraw-e)
435                 (cdr (manyraw-unraw-slot-just-for-variety m)))))
436
437 (defstruct (manyraw-subclass (:include manyraw))
438   (stolperstein 0 :type (unsigned-byte 32)))
439
440 ;;; create lots of manyraw objects, triggering GC every now and then
441 (dotimes (y +n-manyraw+)
442   (dotimes (x +m-manyraw+)
443     (let ((a (random (expt 2 32)))
444           (b (random most-positive-single-float))
445           (c (random most-positive-double-float))
446           (d (complex
447               (random most-positive-single-float)
448               (random most-positive-single-float)))
449           (e (complex
450               (random most-positive-double-float)
451               (random most-positive-double-float))))
452       (push (funcall (if (zerop (mod x 3))
453                          #'make-manyraw-subclass
454                          #'make-manyraw)
455                      :unraw-slot-just-for-variety
456                      (list (+ x (* y +m-manyraw+)) a b c d e)
457                      :a a
458                      :b b
459                      :c c
460                      :d d
461                      :e e)
462             *manyraw*)))
463   (room)
464   (sb-ext:gc))
465 (with-test (:name :defstruct-raw-slot-gc)
466   (check-manyraws *manyraw*))
467
468 ;;; try a full GC, too
469 (sb-ext:gc :full t)
470 (with-test (:name (:defstruct-raw-slot-gc :full))
471   (check-manyraws *manyraw*))
472
473 ;;; fasl dumper and loader also have special handling of raw slots, so
474 ;;; dump all of them into a fasl
475 (defmethod make-load-form ((self manyraw) &optional env)
476   self env
477   :sb-just-dump-it-normally)
478 (with-open-file (s "tmp-defstruct.manyraw.lisp"
479                  :direction :output
480                  :if-exists :supersede)
481   (write-string "(defun dumped-manyraws () '#.*manyraw*)" s))
482 (compile-file "tmp-defstruct.manyraw.lisp")
483 (delete-file "tmp-defstruct.manyraw.lisp")
484
485 ;;; nuke the objects and try another GC just to be extra careful
486 (setf *manyraw* nil)
487 (sb-ext:gc :full t)
488
489 ;;; re-read the dumped structures and check them
490 (load "tmp-defstruct.manyraw.fasl")
491 (with-test (:name (:defstruct-raw-slot load))
492   (check-manyraws (dumped-manyraws)))
493
494 \f
495 ;;;; miscellaneous old bugs
496
497 (defstruct ya-struct)
498 (when (ignore-errors (or (ya-struct-p) 12))
499   (error "YA-STRUCT-P of no arguments should signal an error."))
500 (when (ignore-errors (or (ya-struct-p 'too 'many 'arguments) 12))
501   (error "YA-STRUCT-P of three arguments should signal an error."))
502
503 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
504 ;;; declared inside on the theory that slot types were already
505 ;;; checked, which bogusly suppressed unbound-variable and other
506 ;;; checks within the evaluation of initforms.
507 (defvar *bug210*)
508 (defstruct (bug210a (:constructor bug210a ()))
509   (slot *bug210*))
510 (defstruct bug210b
511   (slot *bug210*))
512 ;;; Because of bug 210, this assertion used to fail.
513 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable))
514 ;;; Even with bug 210, these assertions succeeded.
515 (assert (typep (nth-value 1 (ignore-errors *bug210*)) 'unbound-variable))
516 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable))
517
518 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
519 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
520 ;;; setting up compiler-layout information would run before the
521 ;;; constructor function installing the layout was compiled. Make sure
522 ;;; that doesn't happen again.
523 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x (y :not)))
524 (assert (not (find-class 'foo-0-7-8-53 nil)))
525 (foo-0-7-8-53)
526 (assert (find-class 'foo-0-7-8-53 nil))
527 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x :s)))
528   (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
529   (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))
530 \f
531 ;;; tests of behaviour of colliding accessors.
532 (defstruct (bug127-foo (:conc-name bug127-baz-)) a)
533 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
534 (defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
535 (assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
536 (assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
537 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
538
539 (defun bug127-flurble (x)
540   x)
541 (defstruct bug127 flurble)
542 (assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
543
544 (defstruct bug127-a b-c)
545 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
546 (defstruct (bug127-a-b (:include bug127-a)) c)
547 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
548 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
549
550 (defstruct (bug127-e (:conc-name bug127--)) foo)
551 (assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
552 (defstruct (bug127-f (:conc-name bug127--)) foo)
553 (assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
554 (assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error))
555
556 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
557 \f
558 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
559 ;;; too fragile:
560 (defstruct (conc-name-syntax :conc-name) a-conc-name-slot)
561 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y))
562             'y))
563 ;;; and further :CONC-NAME NIL was being wrongly treated:
564 (defpackage "DEFSTRUCT-TEST-SCRATCH")
565 (defstruct (conc-name-nil :conc-name)
566   defstruct-test-scratch::conc-name-nil-slot)
567 (assert (= (defstruct-test-scratch::conc-name-nil-slot
568             (make-conc-name-nil :conc-name-nil-slot 1)) 1))
569 (assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
570                        undefined-function))
571 \f
572 ;;; The named/typed predicates were a little fragile, in that they
573 ;;; could throw errors on innocuous input:
574 (defstruct (list-struct (:type list) :named) a-slot)
575 (assert (list-struct-p (make-list-struct)))
576 (assert (not (list-struct-p nil)))
577 (assert (not (list-struct-p 1)))
578 (defstruct (offset-list-struct (:type list) :named (:initial-offset 1)) a-slot)
579 (assert (offset-list-struct-p (make-offset-list-struct)))
580 (assert (not (offset-list-struct-p nil)))
581 (assert (not (offset-list-struct-p 1)))
582 (assert (not (offset-list-struct-p '(offset-list-struct))))
583 (assert (not (offset-list-struct-p '(offset-list-struct . 3))))
584 (defstruct (vector-struct (:type vector) :named) a-slot)
585 (assert (vector-struct-p (make-vector-struct)))
586 (assert (not (vector-struct-p nil)))
587 (assert (not (vector-struct-p #())))
588 \f
589
590 ;;; bug 3d: type safety with redefined type constraints on slots
591 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
592 (macrolet
593     ((test (type)
594        (let* ((base-name (intern (format nil "bug3d-~A" type)))
595               (up-name (intern (format nil "~A-up" base-name)))
596               (accessor (intern (format nil "~A-X" base-name)))
597               (up-accessor (intern (format nil "~A-X" up-name)))
598               (type-options (when type `((:type ,type)))))
599          `(progn
600             (defstruct (,base-name ,@type-options)
601               x y)
602             (defstruct (,up-name (:include ,base-name
603                                            (x "x" :type simple-string)
604                                            (y "y" :type simple-string))
605                                  ,@type-options))
606             (let ((ob (,(intern (format nil "MAKE-~A" up-name)))))
607               (setf (,accessor ob) 0)
608               (loop for decl in '(inline notinline)
609                     for fun = `(lambda (s)
610                                  (declare (optimize (safety 3))
611                                           (,decl ,',up-accessor))
612                                  (,',up-accessor s))
613                     do (assert (raises-error? (funcall (compile nil fun) ob)
614                                               type-error))))))))
615   (test nil)
616   (test list)
617   (test vector))
618
619 (let* ((name (gensym))
620        (form `(defstruct ,name
621                 (x nil :type (or null (function (integer)
622                                                 (values number &optional foo)))))))
623   (eval (copy-tree form))
624   (eval (copy-tree form)))
625
626 ;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
627 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
628 ;;; test suite.
629 (defstruct (bug-332a (:type list) (:initial-offset 5) :named))
630 (defstruct (bug-332b (:type list) (:initial-offset 2) :named (:include bug-332a)))
631 (assert (not (bug-332b-p (list* nil nil nil nil nil 'foo73 nil 'tail))))
632 (assert (not (bug-332b-p 873257)))
633 (assert (not (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332a))))
634 (assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b)))
635
636 ;;; Similar test for vectors, just for good measure.
637 (defstruct (bug-332a-aux (:type vector)
638                          (:initial-offset 5) :named))
639 (defstruct (bug-332b-aux (:type vector)
640                          (:initial-offset 2) :named
641                          (:include bug-332a-aux)))
642 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end))))
643 (assert (not (bug-332b-aux-p 873257)))
644 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux))))
645 (assert (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332b-aux)))
646
647 ;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
648 ;;; slot accessors signalled a condition at macroexpansion time, not
649 ;;; when the code was actually compiled or loaded.
650 (let ((defstruct-form '(defstruct bug-in-0-8-11-8 x)))
651   (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
652   (handler-case (macroexpand defstruct-form)
653     (warning (c)
654       (error "shouldn't warn just from macroexpansion here"))))
655
656 ;;; bug 318 symptom no 1. (rest not fixed yet)
657 (catch :ok
658   (handler-bind ((error (lambda (c)
659                           ;; Used to cause stack-exhaustion
660                           (unless (typep c 'storage-condition)
661                             (throw :ok t)))))
662     (eval '(progn
663             (defstruct foo a)
664             (setf (find-class 'foo) nil)
665             (defstruct foo slot-1)))))
666
667 ;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
668 ;;; Melis.
669 (defstruct bug-348 x)
670
671 (assert (eql -1 (let ((i (eval '-2))
672                       (x (make-bug-348)))
673                   (funcall #'(setf bug-348-x)
674                            (incf i)
675                            (aref (vector x) (incf i)))
676                   (bug-348-x x))))
677
678 ;;; obsolete instance trapping
679 ;;;
680 ;;; FIXME: Both error conditions below should possibly be instances
681 ;;; of the same class. (Putting this FIXME here, since this is the only
682 ;;; place where they appear together.)
683
684 (with-test (:name :obsolete-defstruct/print-object)
685   (eval '(defstruct born-to-change))
686   (let ((x (make-born-to-change)))
687     (handler-bind ((error 'continue))
688       (eval '(defstruct born-to-change slot)))
689     (assert (eq :error
690                 (handler-case
691                     (princ-to-string x)
692                   (sb-pcl::obsolete-structure ()
693                     :error))))))
694
695 (with-test (:name :obsolete-defstruct/typep)
696   (eval '(defstruct born-to-change-2))
697   (let ((x (make-born-to-change-2)))
698     (handler-bind ((error 'continue))
699       (eval '(defstruct born-to-change-2 slot)))
700       (assert (eq :error2
701                   (handler-case
702                       (typep x (find-class 'standard-class))
703                     (sb-kernel:layout-invalid ()
704                       :error2))))))
705
706 ;; EQUALP didn't work for structures with float slots (reported by
707 ;; Vjacheslav Fyodorov).
708 (defstruct raw-slot-equalp-bug
709   (b 0s0 :type single-float)
710   c
711   (a 0d0 :type double-float))
712
713 (defstruct raw-slot-equalp-bug-2
714   (b (complex 1d0) :type (complex double-float))
715   (x (complex 1d0) :type (complex double-float))
716   c
717   (a 1s0 :type single-float))
718
719 (with-test (:name :raw-slot-equalp)
720   (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
721                   (make-raw-slot-equalp-bug :a 1d0 :b 2s0)))
722   (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 0s0)
723                   (make-raw-slot-equalp-bug :a 1d0 :b -0s0)))
724   (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
725                        (make-raw-slot-equalp-bug :a 1d0 :b 3s0))))
726   (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
727                        (make-raw-slot-equalp-bug :a 2d0 :b 2s0))))
728   (assert (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
729                   (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)))
730   (assert (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 0s0)
731                   (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a -0s0)))
732   (assert (not (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
733                        (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 3s0))))
734   (assert (not (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
735                        (make-raw-slot-equalp-bug-2 :b (complex 2d0) :a 2s0)))))
736
737 ;;; Check that all slot types (non-raw and raw) can be initialized with
738 ;;; constant arguments.
739 (defstruct constant-arg-inits
740   (a 42 :type t)
741   (b 1 :type fixnum)
742   (c 2 :type sb-vm:word)
743   (d 3.0 :type single-float)
744   (e 4.0d0 :type double-float)
745   (f #c(5.0 5.0) :type (complex single-float))
746   (g #c(6.0d0 6.0d0) :type (complex double-float)))
747 (defun test-constant-arg-inits ()
748   (let ((foo (make-constant-arg-inits)))
749     (declare (dynamic-extent foo))
750     (assert (eql 42 (constant-arg-inits-a foo)))
751     (assert (eql 1 (constant-arg-inits-b foo)))
752     (assert (eql 2 (constant-arg-inits-c foo)))
753     (assert (eql 3.0 (constant-arg-inits-d foo)))
754     (assert (eql 4.0d0 (constant-arg-inits-e foo)))
755     (assert (eql #c(5.0 5.0) (constant-arg-inits-f foo)))
756     (assert (eql #c(6.0d0 6.0d0) (constant-arg-inits-g foo)))))
757 (make-constant-arg-inits)
758
759 ;;; bug reported by John Morrison, 2008-07-22 on sbcl-devel
760 (defstruct (raw-slot-struct-with-unknown-init (:constructor make-raw-slot-struct-with-unknown-init ()))
761  (x (#:unknown-function) :type double-float))
762 \f
763 ;;; Some checks for the behavior of incompatibly redefining structure
764 ;;; classes.  We don't actually check that our detection of
765 ;;; "incompatible" is comprehensive, only that if an incompatible
766 ;;; definition is processed, we do various things.
767 (defmacro with-files ((&rest vars) &body body)
768   "Evaluate BODY with VARS bound to a number of filenames, then
769 delete the files at the end."
770   (let* ((paths (loop for var in vars
771                       as index upfrom 0
772                       collect (make-pathname
773                                    :case :common
774                                    :name (format nil
775                                                  "DEFSTRUCT-REDEF-TEST-~D"
776                                                  index)
777                                    :type "LISP")))
778          (binding-spec (mapcar
779                         (lambda (var path) `(,var ,path)) vars paths)))
780     (labels ((frob (n)
781                `((unwind-protect
782                      (progn
783                        ,@(if (plusp n)
784                              (frob (1- n))
785                              body))
786                    (delete-file ,(elt paths n))))))
787       `(let ,binding-spec
788          ,@(frob (1- (length vars)))))))
789
790 (defun noclobber (pathspec &rest forms)
791   "Write FORMS to the file named by PATHSPEC, erroring if
792 PATHSPEC already names an existing file."
793   (with-open-file (*standard-output* pathspec :direction :output
794                                      :if-exists :error)
795     (print '(in-package "CL-USER"))
796     (mapc #'print forms)))
797
798 (defun compile-file-assert (file &optional (want-error-p t) (want-warning-p t))
799   "Compile FILE and assert some things about the results."
800   (multiple-value-bind (fasl errors-p warnings-p)
801       (compile-file file)
802     (assert fasl)
803     (assert (eq errors-p want-error-p))
804     (assert (eq warnings-p want-warning-p))
805     fasl))
806
807 (defun continue-from-incompatible-defstruct-error (error)
808   "Invoke the CONTINUE restart for an incompatible DEFSTRUCT
809 redefinition."
810   ;; FIXME: want distinct error type for incompatible defstruct.
811   (when (search "attempt to redefine" (simple-condition-format-control error))
812     (when (find-restart 'continue)
813       (invoke-restart 'continue))))
814
815 (defun recklessly-continue-from-incompatible-defstruct-error (error)
816   "Invoke the RECKLESSLY-CONTINUE restart for an incompatible DEFSTRUCT
817 redefinition."
818   ;; FIXME: want distinct error type for incompatible defstruct.
819   (when (search "attempt to redefine" (simple-condition-format-control error))
820     (when (find-restart 'sb-kernel::recklessly-continue)
821       (invoke-restart 'sb-kernel::recklessly-continue))))
822
823 (defun assert-is (predicate instance)
824   (assert (funcall predicate instance)))
825
826 (defun assert-invalid (predicate instance)
827   (assert (typep (nth-value 1 (ignore-errors (funcall predicate instance)))
828                  'sb-kernel::layout-invalid)))
829
830 ;; Don't try to understand this macro; just look at its expansion.
831 (defmacro with-defstruct-redefinition-test (name
832                                             (&rest defstruct-form-bindings)
833                                             (&rest path-form-specs)
834                                             handler-function
835                                             &body body)
836   (labels ((make-defstruct-form (&key class-name super-name slots)
837              (let* ((predicate-name
838                      (read-from-string (format nil "~A-p" class-name)))
839                     (constructor-name
840                      (read-from-string (format nil "make-~A" class-name))))
841                `(values
842                  '(defstruct (,class-name
843                              (:constructor ,constructor-name)
844                              ,@(when super-name
845                                  `((:include ,super-name))))
846                     ,@slots)
847                  ',constructor-name
848                  ',predicate-name)))
849            (frob (bindspecs classno)
850              (if bindspecs
851                  `((multiple-value-bind ,(first (first bindspecs))
852                        ,(apply #'make-defstruct-form (rest (first bindspecs)))
853                      (declare (ignorable ,@(first (first bindspecs))))
854                      ,@(frob (rest bindspecs) (1+ classno))))
855                  `((with-files ,(mapcar #'first path-form-specs)
856                      ,@(mapcar (lambda (path-form) `(noclobber ,@path-form))
857                                path-form-specs)
858                      (handler-bind
859                          ((simple-error ',handler-function))
860                        ,@body))))))
861     `(with-test (:name ,name)
862       ,(first (frob defstruct-form-bindings 0)))))
863
864 ;; When eyeballing these, it's helpful to see when various things are
865 ;; happening.
866 (setq *compile-verbose* t *load-verbose* t)
867 \f
868 ;;; Tests begin.
869 ;; Base case: recklessly-continue.
870 (with-defstruct-redefinition-test :defstruct/recklessly
871     (((defstruct ctor pred) :class-name redef-test-1 :slots (a))
872      ((defstruct*) :class-name redef-test-1 :slots (a b)))
873     ((path1 defstruct)
874      (path2 defstruct*))
875     recklessly-continue-from-incompatible-defstruct-error
876   (load path1)
877   (let ((instance (funcall ctor)))
878     (load path2)
879     (assert-is pred instance)))
880
881 ;; Base case: continue (i.e., invalidate instances).
882 (with-defstruct-redefinition-test :defstruct/continue
883     (((defstruct ctor pred) :class-name redef-test-2 :slots (a))
884      ((defstruct*) :class-name redef-test-2 :slots (a b)))
885     ((path1 defstruct)
886      (path2 defstruct*))
887     continue-from-incompatible-defstruct-error
888   (load path1)
889   (let ((instance (funcall ctor)))
890     (load path2)
891     (assert-invalid pred instance)))
892
893 ;; Compiling a file with an incompatible defstruct should emit a
894 ;; warning and an error, but the fasl should be loadable.
895 (with-defstruct-redefinition-test :defstruct/compile-file-should-warn
896     (((defstruct) :class-name redef-test-3 :slots (a))
897      ((defstruct*) :class-name redef-test-3 :slots (a b)))
898     ((path1 defstruct)
899      (path2 defstruct*))
900     continue-from-incompatible-defstruct-error
901   (load path1)
902   (load (compile-file-assert path2)))
903
904 ;; After compiling a file with an incompatible DEFSTRUCT, load the
905 ;; fasl and ensure that an old instance remains valid.
906 (with-defstruct-redefinition-test :defstruct/compile-file-reckless
907     (((defstruct ctor pred) :class-name redef-test-4 :slots (a))
908      ((defstruct*) :class-name redef-test-4 :slots (a b)))
909     ((path1 defstruct)
910      (path2 defstruct*))
911     recklessly-continue-from-incompatible-defstruct-error
912   (load path1)
913   (let ((instance (funcall ctor)))
914     (load (compile-file-assert path2))
915     (assert-is pred instance)))
916
917 ;; After compiling a file with an incompatible DEFSTRUCT, load the
918 ;; fasl and ensure that an old instance has become invalid.
919 (with-defstruct-redefinition-test :defstruct/compile-file-continue
920     (((defstruct ctor pred) :class-name redef-test-5 :slots (a))
921      ((defstruct*) :class-name redef-test-5 :slots (a b)))
922     ((path1 defstruct)
923      (path2 defstruct*))
924     continue-from-incompatible-defstruct-error
925   (load path1)
926   (let ((instance (funcall ctor)))
927     (load (compile-file-assert path2))
928     (assert-invalid pred instance)))
929 \f
930 ;;; Subclasses.
931 ;; Ensure that recklessly continuing DT(expected)T to instances of
932 ;; subclasses.  (This is a case where recklessly continuing is
933 ;; actually dangerous, but we don't care.)
934 (with-defstruct-redefinition-test :defstruct/subclass-reckless
935     (((defstruct ignore pred1) :class-name redef-test-6 :slots (a))
936      ((substruct ctor pred2) :class-name redef-test-6-sub
937                              :super-name redef-test-6 :slots (z))
938      ((defstruct*) :class-name redef-test-6 :slots (a b)))
939     ((path1 defstruct substruct)
940      (path2 defstruct* substruct))
941     recklessly-continue-from-incompatible-defstruct-error
942   (load path1)
943   (let ((instance (funcall ctor)))
944     (load (compile-file-assert path2))
945     (assert-is pred1 instance)
946     (assert-is pred2 instance)))
947
948 ;; Ensure that continuing invalidates instances of subclasses.
949 (with-defstruct-redefinition-test :defstruct/subclass-continue
950     (((defstruct) :class-name redef-test-7 :slots (a))
951      ((substruct ctor pred) :class-name redef-test-7-sub
952                             :super-name redef-test-7 :slots (z))
953      ((defstruct*) :class-name redef-test-7 :slots (a b)))
954     ((path1 defstruct substruct)
955      (path2 defstruct* substruct))
956     continue-from-incompatible-defstruct-error
957   (load path1)
958   (let ((instance (funcall ctor)))
959     (load (compile-file-assert path2))
960     (assert-invalid pred instance)))
961
962 ;; Reclkessly continuing doesn't invalidate instances of subclasses.
963 (with-defstruct-redefinition-test :defstruct/subclass-in-other-file-reckless
964     (((defstruct ignore pred1) :class-name redef-test-8 :slots (a))
965      ((substruct ctor pred2) :class-name redef-test-8-sub
966                              :super-name redef-test-8 :slots (z))
967      ((defstruct*) :class-name redef-test-8 :slots (a b)))
968     ((path1 defstruct)
969      (path2 substruct)
970      (path3 defstruct*))
971     recklessly-continue-from-incompatible-defstruct-error
972   (load path1)
973   (load path2)
974   (let ((instance (funcall ctor)))
975     (load (compile-file-assert path3))
976     (assert-is pred1 instance)
977     (assert-is pred2 instance)))
978
979 ;; This is an icky case: when a subclass is defined in a separate
980 ;; file, CONTINUE'ing from LOAD of a file containing an incompatible
981 ;; superclass definition leaves the predicates and accessors into the
982 ;; subclass in a bad way until the subclass form is evaluated.
983 (with-defstruct-redefinition-test :defstruct/subclass-in-other-file-continue
984     (((defstruct ignore pred1) :class-name redef-test-9 :slots (a))
985      ((substruct ctor pred2) :class-name redef-test-9-sub
986                              :super-name redef-test-9 :slots (z))
987      ((defstruct*) :class-name redef-test-9 :slots (a b)))
988     ((path1 defstruct)
989      (path2 substruct)
990      (path3 defstruct*))
991     continue-from-incompatible-defstruct-error
992   (load path1)
993   (load path2)
994   (let ((instance (funcall ctor)))
995     (load (compile-file-assert path3))
996     ;; At this point, the instance of the subclass will not count as
997     ;; an instance of the superclass or of the subclass, but PRED2's
998     ;; predicate will error with "an obsolete structure accessor
999     ;; function was called".
1000     (assert-invalid pred1 instance)
1001     (format t "~&~A~%" (nth-value 1 (ignore-errors (funcall pred2 instance))))
1002     ;; After loading PATH2, we'll get the desired LAYOUT-INVALID error.
1003     (load path2)
1004     (assert-invalid pred2 instance)))
1005
1006 ;; Some other subclass wrinkles have to do with splitting definitions
1007 ;; accross files and compiling and loading things in a funny order.
1008 (with-defstruct-redefinition-test
1009     :defstruct/subclass-in-other-file-funny-operation-order-continue
1010     (((defstruct ignore pred1) :class-name redef-test-10 :slots (a))
1011      ((substruct ctor pred2) :class-name redef-test-10-sub
1012                              :super-name redef-test-10 :slots (z))
1013      ((defstruct*) :class-name redef-test-10 :slots (a b)))
1014     ((path1 defstruct)
1015      (path2 substruct)
1016      (path3 defstruct*))
1017     continue-from-incompatible-defstruct-error
1018   (load path1)
1019   (load path2)
1020   (let ((instance (funcall ctor)))
1021     ;; First we clobber the compiler's layout for the superclass.
1022     (compile-file-assert path3)
1023     ;; Then we recompile the subclass definition (which generates a
1024     ;; warning about the compiled layout for the superclass being
1025     ;; incompatible with the loaded layout, because we haven't loaded
1026     ;; path3 since recompiling).
1027     (compile-file path2)
1028     ;; Ugh.  I don't want to think about loading these in the wrong
1029     ;; order.
1030     (load (compile-file-pathname path3))
1031     (load (compile-file-pathname path2))
1032     (assert-invalid pred1 instance)
1033     (assert-invalid pred2 instance)))
1034
1035 (with-defstruct-redefinition-test
1036     :defstruct/subclass-in-other-file-funny-operation-order-continue
1037     (((defstruct ignore pred1) :class-name redef-test-11 :slots (a))
1038      ((substruct ctor pred2) :class-name redef-test-11-sub
1039                              :super-name redef-test-11 :slots (z))
1040      ((defstruct*) :class-name redef-test-11 :slots (a b)))
1041     ((path1 defstruct)
1042      (path2 substruct)
1043      (path3 defstruct*))
1044     continue-from-incompatible-defstruct-error
1045   (load path1)
1046   (load path2)
1047   (let ((instance (funcall ctor)))
1048     ;; This clobbers the compiler's layout for REDEF-TEST-11.
1049     (compile-file-assert path3)
1050     ;; This recompiles REDEF-TEST-11-SUB, using the new REDEF-TEST-11
1051     ;; compiler-layout.
1052     (load (compile-file-pathname path2))
1053     ;; Note that because we haven't loaded PATH3, we haven't clobbered
1054     ;; the class's layout REDEF-TEST-11, so REDEF-11's predicate will
1055     ;; still work.  That's probably bad.
1056     (assert-is pred1 instance)
1057     (assert-is pred2 instance)))
1058
1059 (with-test (:name :raw-slot/circle-subst)
1060   ;; CIRCLE-SUBSTS used %INSTANCE-REF on raw slots
1061   (multiple-value-bind (list n)
1062       (eval '(progn
1063               (defstruct raw-slot/circle-subst
1064                 (x 0.0 :type single-float))
1065               (read-from-string "((#1=#S(raw-slot/circle-subst :x 2.7158911)))")))
1066     (destructuring-bind ((struct)) list
1067       (assert (raw-slot/circle-subst-p struct))
1068       (assert (eql 2.7158911 (raw-slot/circle-subst-x struct)))
1069       (assert (eql 45 n)))))
1070
1071 (defstruct (bug-3b (:constructor make-bug-3b (&aux slot)))
1072   (slot nil :type string))
1073
1074 (with-test (:name :bug-3b)
1075   (handler-case
1076       (progn
1077         (bug-3b-slot (make-bug-3b))
1078         (error "fail"))
1079     (type-error (e)
1080       (assert (eq 'string (type-error-expected-type e)))
1081       (assert (zerop (type-error-datum e))))))
1082
1083 (with-test (:name :defstruct-copier-typechecks-argument)
1084   (assert (not (raises-error? (copy-person (make-astronaut :name "Neil")))))
1085   (assert (raises-error? (copy-astronaut (make-person :name "Fred")))))
1086
1087 (with-test (:name :bug-528807)
1088   (let ((*evaluator-mode* :compile))
1089     (handler-bind ((style-warning #'error))
1090       (eval `(defstruct (bug-528807 (:constructor make-528807 (&aux x)))
1091                (x nil :type fixnum))))))
1092
1093 (with-test (:name :bug-520607)
1094   (assert
1095     (raises-error?
1096       (eval '(defstruct (typed-struct (:type list) (:predicate typed-struct-p))
1097               (a 42 :type fixnum)))))
1098   ;; NIL is ok, though.
1099   (eval '(defstruct (typed-struct (:type list) (:predicate nil))
1100           (a 42 :type fixnum)))
1101   ;; So's empty.
1102   (eval '(defstruct (typed-struct2 (:type list) (:predicate))
1103           (a 42 :type fixnum))))
1104
1105 (with-test (:name (:boa-supplied-p &optional))
1106   (handler-bind ((warning #'error))
1107     (eval `(defstruct (boa-supplied-p.1 (:constructor make-boa-supplied-p.1
1108                                             (&optional (bar t barp))))
1109              bar
1110              barp)))
1111   (let ((b1 (make-boa-supplied-p.1))
1112         (b2 (make-boa-supplied-p.1 t)))
1113     (assert (eq t (boa-supplied-p.1-bar b1)))
1114     (assert (eq t (boa-supplied-p.1-bar b2)))
1115     (assert (eq nil (boa-supplied-p.1-barp b1)))
1116     (assert (eq t (boa-supplied-p.1-barp b2)))))
1117
1118 (with-test (:name (:boa-supplied-p &key))
1119   (handler-bind ((warning #'error))
1120     (eval `(defstruct (boa-supplied-p.2 (:constructor make-boa-supplied-p.2
1121                                             (&key (bar t barp))))
1122              bar
1123              barp)))
1124   (let ((b1 (make-boa-supplied-p.2))
1125         (b2 (make-boa-supplied-p.2 :bar t)))
1126     (assert (eq t (boa-supplied-p.2-bar b1)))
1127     (assert (eq t (boa-supplied-p.2-bar b2)))
1128     (assert (eq nil (boa-supplied-p.2-barp b1)))
1129     (assert (eq t (boa-supplied-p.2-barp b2)))))
1130
1131 (defstruct structure-with-predicate)
1132 (defclass class-to-be-redefined () ())
1133 (let ((x (make-instance 'class-to-be-redefined)))
1134   (defun function-trampoline (fun) (funcall fun x)))
1135
1136 (with-test (:name (:struct-predicate :obsolete-instance))
1137   (defclass class-to-be-redefined () ((a :initarg :a :initform 1)))
1138   (function-trampoline #'structure-with-predicate-p))
1139
1140 (with-test (:name (:defstruct :not-toplevel-silent))
1141   (let ((sb-ext:*evaluator-mode* :compile))
1142     (handler-bind ((warning #'error))
1143      (eval `(let ()
1144               (defstruct defstruct-no-warning-not-at-toplevel bar))))))
1145
1146 (with-test (:name :bug-941102)
1147   (let ((test `((defstruct bug-941102)
1148                  (setf (find-class 'bug-941102-alias) (find-class 'bug-941102))
1149                  (setf (find-class 'bug-941102-alias) nil))))
1150     (multiple-value-bind (warn fail) (ctu:file-compile test :load t)
1151       (assert (not warn))
1152       (assert (not fail)))
1153     (multiple-value-bind (warn2 fail2) (ctu:file-compile test)
1154       (assert (not warn2))
1155       (assert (not fail2)))))
1156
1157 (with-test (:name (defstruct :constant-slot-names))
1158   (defstruct defstruct-constant-slot-names t)
1159   (assert (= 3 (defstruct-constant-slot-names-t
1160                 (make-defstruct-constant-slot-names :t 3)))))