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