1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (load "compiler-test-util.lisp")
13 (use-package "ASSERTOID")
15 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
17 ;;; Type mismatch of slot default init value isn't an error until the
18 ;;; default init value is actually used. (The justification is
19 ;;; somewhat bogus, but the requirement is clear.)
20 (defstruct person age
(name 007 :type string
)) ; not an error until 007 used
21 (make-person :name
"James") ; not an error, 007 not used
23 #.
(if (legacy-eval-p) (values)
24 '(assert-error (make-person) type-error
))
25 #.
(if (legacy-eval-p) (values)
26 '(assert-error (setf (person-name (make-person :name
"Q")) 1)
29 ;;; An &AUX variable in a boa-constructor without a default value
30 ;;; means "do not initialize slot" and does not cause type error
31 (declaim (notinline opaque-identity
))
32 (defun opaque-identity (x) x
)
34 (with-test (:name
:defstruct-boa-typecheck
)
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))
42 (assert-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
51 (with-test (:name
:defstruct-boa-no-error
:skipped-on
:interpreter
)
52 (let ((s (make-boa-saux)))
53 (locally (declare (optimize (safety 0))
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))))
62 (with-test (:name
:defstruct-boa-typecheck
.2)
63 (let ((s (make-boa-saux)))
64 (locally (declare (optimize (safety 3))
65 (notinline boa-saux-a
))
66 (assert-error (opaque-identity (boa-saux-a s
)) type-error
))
67 (setf (boa-saux-a s
) 1)
68 (setf (boa-saux-c s
) 5)
69 (assert (eql (boa-saux-a s
) 1))
70 (assert (eql (boa-saux-b s
) 3))
71 (assert (eql (boa-saux-c s
) 5))))
74 (defstruct (astronaut (:include person
)
77 (favorite-beverage 'tang
))
78 (let ((x (make-astronaut :name
"Buzz" :helmet-size
17.5)))
79 (assert (equal (person-name x
) "Buzz"))
80 (assert (equal (astro-name x
) "Buzz"))
81 (assert (eql (astro-favorite-beverage x
) 'tang
))
82 (assert (null (astro-age x
))))
83 (defstruct (ancient-astronaut (:include person
(age 77)))
85 (favorite-beverage 'tang
))
86 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name
"John")) 77))
88 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
89 (defstruct (binop (:type list
) :named
(:initial-offset
2))
90 (operator '?
:type symbol
)
93 (defstruct (annotated-binop (:type list
)
96 commutative associative identity
)
97 (assert (equal (make-annotated-binop :operator
'*
103 '(nil nil binop
* x
5 nil nil nil t t
1)))
105 ;;; effect of :NAMED on :TYPE
106 (defstruct (named-binop (:type list
) :named
)
107 (operator '?
:type symbol
)
110 (let ((named-binop (make-named-binop :operator
'+ :operand-1
'x
:operand-2
5)))
111 ;; The data representation is specified to look like this.
112 (assert (equal named-binop
'(named-binop + x
5)))
113 ;; A meaningful NAMED-BINOP-P is defined.
114 (assert (named-binop-p named-binop
))
115 (assert (named-binop-p (copy-list named-binop
)))
116 (assert (not (named-binop-p (cons 11 named-binop
))))
117 (assert (not (named-binop-p (find-package :cl
)))))
123 (firetrucks 1 :type fixnum
)
125 (elevation 5128 :read-only t
))
126 (let ((town1 (make-town :area
0 :watertowers
0)))
127 (assert (town-p town1
))
128 (assert (not (town-p 1)))
129 (assert (eql (town-area town1
) 0))
130 (assert (eql (town-elevation town1
) 5128))
131 (assert (null (town-population town1
)))
132 (setf (town-population town1
) 99)
133 (assert (eql (town-population town1
) 99))
134 (let ((town2 (copy-town town1
)))
135 (dolist (slot-accessor-name '(town-area
140 (assert (eql (funcall slot-accessor-name town1
)
141 (funcall slot-accessor-name town2
))))
142 (assert (not (fboundp '(setf town-elevation
)))) ; 'cause it's :READ-ONLY
143 ;; The source-transform for SETF was too eager,
144 ;; and would accept read-only slots.
146 (setf (town-elevation (make-town)) 5))
148 (funcall (compile nil
(lambda (x y
)
149 (setf (town-readonly x
) y
)
154 (defstruct (clown (:conc-name bozo-
))
158 (let ((funny-clown (make-clown)))
159 (assert (eql (bozo-nose-color funny-clown
) 'red
)))
160 (defstruct (klown (:constructor make-up-klown
)
161 (:copier clone-klown
)
162 (:predicate is-a-bozo-p
))
166 (assert (is-a-bozo-p (make-up-klown)))
168 ;;;; systematically testing variants of DEFSTRUCT:
169 ;;;; * native, :TYPE LIST, and :TYPE VECTOR
171 ;;; FIXME: things to test:
172 ;;; * Slot readers work.
173 ;;; * Slot writers work.
174 ;;; * Predicates work.
176 ;;; FIXME: things that would be nice to test systematically someday:
177 ;;; * constructors (default, boa..)
179 ;;; * no type checks when (> SPEED SAFETY)
180 ;;; * Tests of inclusion would be good. (It's tested very lightly
181 ;;; above, and then tested a fair amount by the system compiling
184 (defun string+ (&rest rest
)
185 (apply #'concatenate
'string
186 (mapcar #'string rest
)))
187 (defun symbol+ (&rest rest
)
188 (values (intern (apply #'string
+ rest
))))
190 (defun accessor-name (conc-name slot-name
)
191 (symbol+ conc-name slot-name
))
193 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
194 ;;; to read and write a structure slot.
195 (defun read-slot-notinline (conc-name slot-name instance
)
196 (funcall (accessor-name conc-name slot-name
) instance
))
197 (defun write-slot-notinline (new-value conc-name slot-name instance
)
198 (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name
)))
201 ;;; Use inline expansions of slot accessors, if possible, to read and
202 ;;; write a structure slot.
203 (defun read-slot-inline (conc-name slot-name instance
)
204 (funcall (compile nil
206 (,(accessor-name conc-name slot-name
) instance
)))
208 (defun write-slot-inline (new-value conc-name slot-name instance
)
209 (funcall (compile nil
210 `(lambda (new-value instance
)
211 (setf (,(accessor-name conc-name slot-name
) instance
)
216 ;;; Read a structure slot, checking that the inline and out-of-line
217 ;;; accessors give the same result.
218 (defun read-slot (conc-name slot-name instance
)
219 (let ((inline-value (read-slot-inline conc-name slot-name instance
))
220 (notinline-value (read-slot-notinline conc-name slot-name instance
)))
221 (assert (eql inline-value notinline-value
))
224 ;;; Write a structure slot, using INLINEP argument to decide
225 ;;; on inlineness of accessor used.
226 (defun write-slot (new-value conc-name slot-name instance inlinep
)
228 (write-slot-inline new-value conc-name slot-name instance
)
229 (write-slot-notinline new-value conc-name slot-name instance
)))
231 ;;; bound during the tests so that we can get to it even if the
232 ;;; debugger is having a bad day
235 (declaim (optimize (debug 2)))
237 (defmacro test-variant
(defstructname &key colontype boa-constructor-p
)
239 (declare (muffle-conditions style-warning
)) ; &OPTIONAL and &KEY
240 #+nil
(format t
"~&/beginning PROGN for COLONTYPE=~S~%" ',colontype
)
241 (defstruct (,defstructname
242 ,@(when colontype
`((:type
,colontype
)))
243 ,@(when boa-constructor-p
244 `((:constructor
,(symbol+ "CREATE-" defstructname
)
247 (optional-test 2 optional-test-p
)
250 (no-home-comment "Home package CL not provided.")
251 (comment (if home-p
"" no-home-comment
))
252 (refcount (if optional-test-p optional-test nil
))
256 ;; some ordinary tagged slots
258 (home nil
:type package
:read-only t
)
259 (comment "" :type simple-string
)
261 (weight 1.0 :type single-float
)
262 (hash 1 :type
(integer 1 #.
(* 3 most-positive-fixnum
)) :read-only t
)
263 ;; more ordinary tagged slots
264 (refcount 0 :type
(and unsigned-byte fixnum
)))
266 #+nil
(format t
"~&/done with DEFSTRUCT~%")
268 (let* ((cn (string+ ',defstructname
"-")) ; conc-name
269 (ctor (symbol-function ',(symbol+ (if boa-constructor-p
273 (*instance
* (funcall ctor
274 ,@(unless boa-constructor-p
276 ,@(when boa-constructor-p
278 :home
(find-package :cl
)
279 :hash
(+ 14 most-positive-fixnum
)
280 ,@(unless boa-constructor-p
283 ;; Check that ctor set up slot values correctly.
284 #+nil
(format t
"~&/checking constructed structure~%")
285 (assert (string= "some id" (read-slot cn
"ID" *instance
*)))
286 (assert (eql (find-package :cl
) (read-slot cn
"HOME" *instance
*)))
287 (assert (string= "" (read-slot cn
"COMMENT" *instance
*)))
288 (assert (= 1.0 (read-slot cn
"WEIGHT" *instance
*)))
289 (assert (eql (+ 14 most-positive-fixnum
)
290 (read-slot cn
"HASH" *instance
*)))
291 (assert (= 1 (read-slot cn
"REFCOUNT" *instance
*)))
293 ;; There should be no writers for read-only slots.
294 #+nil
(format t
"~&/checking no read-only writers~%")
295 (assert (not (fboundp `(setf ,(symbol+ cn
"HOME")))))
296 (assert (not (fboundp `(setf ,(symbol+ cn
"HASH")))))
297 ;; (Read-only slot values are checked in the loop below.)
299 (dolist (inlinep '(t nil
))
300 #+nil
(format t
"~&/doing INLINEP=~S~%" inlinep
)
301 ;; Fiddle with writable slot values.
302 (let ((new-id (format nil
"~S" (random 100)))
303 (new-comment (format nil
"~X" (random 5555)))
304 (new-weight (random 10.0)))
305 (write-slot new-id cn
"ID" *instance
* inlinep
)
306 (write-slot new-comment cn
"COMMENT" *instance
* inlinep
)
307 (write-slot new-weight cn
"WEIGHT" *instance
* inlinep
)
308 (assert (eql new-id
(read-slot cn
"ID" *instance
*)))
309 (assert (eql new-comment
(read-slot cn
"COMMENT" *instance
*)))
310 ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
311 ;; (error "WEIGHT mismatch: ~S vs. ~S"
312 ;; new-weight (read-slot cn "WEIGHT" *instance*)))
313 (assert (eql new-weight
(read-slot cn
"WEIGHT" *instance
*)))))
314 #+nil
(format t
"~&/done with INLINEP loop~%")
316 ;; :TYPE FOO objects don't go in the Lisp type system, so we
317 ;; can't test TYPEP stuff for them.
319 ;; FIXME: However, when they're named, they do define
320 ;; predicate functions, and we could test those.
322 `(;; Fiddle with predicate function.
323 (let ((pred-name (symbol+ ',defstructname
"-P")))
324 #+nil
(format t
"~&/doing tests on PRED-NAME=~S~%" pred-name
)
325 (assert (funcall pred-name
*instance
*))
326 (assert (not (funcall pred-name
14)))
327 (assert (not (funcall pred-name
"test")))
328 (assert (not (funcall pred-name
(make-hash-table))))
330 (compile nil
`(lambda (x) (,pred-name x
)))))
331 #+nil
(format t
"~&/doing COMPILED-PRED tests~%")
332 (assert (funcall compiled-pred
*instance
*))
333 (assert (not (funcall compiled-pred
14)))
334 (assert (not (funcall compiled-pred
#()))))
335 ;; Fiddle with TYPEP.
336 #+nil
(format t
"~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype
)
337 (assert (typep *instance
* ',defstructname
))
338 (assert (not (typep 0 ',defstructname
)))
339 (assert (funcall (symbol+ "TYPEP") *instance
* ',defstructname
))
340 (assert (not (funcall (symbol+ "TYPEP") nil
',defstructname
)))
341 (let* ((typename ',defstructname
)
343 (compile nil
`(lambda (x) (typep x
',typename
)))))
344 (assert (funcall compiled-typep
*instance
*))
345 (assert (not (funcall compiled-typep nil
))))))))
347 #+nil
(format t
"~&/done with PROGN for COLONTYPE=~S~%" ',colontype
)))
349 (test-variant vanilla-struct
)
350 (test-variant vector-struct
:colontype vector
)
351 (test-variant list-struct
:colontype list
)
352 (test-variant vanilla-struct
:boa-constructor-p t
)
353 (test-variant vector-struct
:colontype vector
:boa-constructor-p t
)
354 (test-variant list-struct
:colontype list
:boa-constructor-p t
)
357 ;;;; testing raw slots harder
359 ;;;; The offsets of raw slots need to be rescaled during the punning
360 ;;;; process which is used to access them. That seems like a good
361 ;;;; place for errors to lurk, so we'll try hunting for them by
362 ;;;; verifying that all the raw slot data gets written successfully
363 ;;;; into the object, can be copied with the object, and can then be
364 ;;;; read back out (with none of it ending up bogusly outside the
365 ;;;; object, so that it couldn't be copied, or bogusly overwriting
366 ;;;; some other raw slot).
369 (a (expt 2 30) :type
(unsigned-byte #.sb-vm
:n-word-bits
))
370 (b 0.1 :type single-float
)
371 (c 0.2d0
:type double-float
)
372 (d #c
(0.3
0.3) :type
(complex single-float
))
373 unraw-slot-just-for-variety
374 (e #c
(0.4d0
0.4d0
) :type
(complex double-float
))
375 (aa (expt 2 30) :type
(unsigned-byte #.sb-vm
:n-word-bits
))
376 (bb 0.1 :type single-float
)
377 (cc 0.2d0
:type double-float
)
378 (dd #c
(0.3
0.3) :type
(complex single-float
))
379 (ee #c
(0.4d0
0.4d0
) :type
(complex double-float
)))
381 (defvar *manyraw
* (make-manyraw))
383 (assert (eql (manyraw-a *manyraw
*) (expt 2 30)))
384 (assert (eql (manyraw-b *manyraw
*) 0.1))
385 (assert (eql (manyraw-c *manyraw
*) 0.2d0
))
386 (assert (eql (manyraw-d *manyraw
*) #c
(0.3
0.3)))
387 (assert (eql (manyraw-e *manyraw
*) #c
(0.4d0
0.4d0
)))
388 (assert (eql (manyraw-aa *manyraw
*) (expt 2 30)))
389 (assert (eql (manyraw-bb *manyraw
*) 0.1))
390 (assert (eql (manyraw-cc *manyraw
*) 0.2d0
))
391 (assert (eql (manyraw-dd *manyraw
*) #c
(0.3
0.3)))
392 (assert (eql (manyraw-ee *manyraw
*) #c
(0.4d0
0.4d0
)))
394 (setf (manyraw-aa *manyraw
*) (expt 2 31)
395 (manyraw-bb *manyraw
*) 0.11
396 (manyraw-cc *manyraw
*) 0.22d0
397 (manyraw-dd *manyraw
*) #c
(0.33
0.33)
398 (manyraw-ee *manyraw
*) #c
(0.44d0
0.44d0
))
400 (let ((copy (copy-manyraw *manyraw
*)))
401 (assert (eql (manyraw-a copy
) (expt 2 30)))
402 (assert (eql (manyraw-b copy
) 0.1))
403 (assert (eql (manyraw-c copy
) 0.2d0
))
404 (assert (eql (manyraw-d copy
) #c
(0.3
0.3)))
405 (assert (eql (manyraw-e copy
) #c
(0.4d0
0.4d0
)))
406 (assert (eql (manyraw-aa copy
) (expt 2 31)))
407 (assert (eql (manyraw-bb copy
) 0.11))
408 (assert (eql (manyraw-cc copy
) 0.22d0
))
409 (assert (eql (manyraw-dd copy
) #c
(0.33
0.33)))
410 (assert (eql (manyraw-ee copy
) #c
(0.44d0
0.44d0
))))
413 ;;;; Since GC treats raw slots specially now, let's try this with more objects
414 ;;;; and random values as a stress test.
418 (defconstant +n-manyraw
+ 10)
419 (defconstant +m-manyraw
+ 1000)
421 (defun check-manyraws (manyraws)
422 (assert (eql (length manyraws
) (* +n-manyraw
+ +m-manyraw
+)))
424 for m in
(reverse manyraws
)
427 ;; Compare the tagged reference values with raw reffer results.
428 (destructuring-bind (j a b c d e
)
429 (manyraw-unraw-slot-just-for-variety m
)
431 (assert (= (manyraw-a m
) a
))
432 (assert (= (manyraw-b m
) b
))
433 (assert (= (manyraw-c m
) c
))
434 (assert (= (manyraw-d m
) d
))
435 (assert (= (manyraw-e m
) e
)))
436 ;; Test the funny out-of-line OAOOM-style closures, too.
437 (mapcar (lambda (fn value
)
438 (assert (= (funcall fn m
) value
)))
444 (cdr (manyraw-unraw-slot-just-for-variety m
)))))
446 (defstruct (manyraw-subclass (:include manyraw
))
447 (stolperstein 0 :type
(unsigned-byte 32)))
449 ;;; create lots of manyraw objects, triggering GC every now and then
450 (dotimes (y +n-manyraw
+)
451 (dotimes (x +m-manyraw
+)
452 (let ((a (random (expt 2 32)))
453 (b (random most-positive-single-float
))
454 (c (random most-positive-double-float
))
456 (random most-positive-single-float
)
457 (random most-positive-single-float
)))
459 (random most-positive-double-float
)
460 (random most-positive-double-float
))))
461 (push (funcall (if (zerop (mod x
3))
462 #'make-manyraw-subclass
464 :unraw-slot-just-for-variety
465 (list (+ x
(* y
+m-manyraw
+)) a b c d e
)
472 (let ((*standard-output
* (make-broadcast-stream))) (room))
474 (with-test (:name
:defstruct-raw-slot-gc
)
475 (check-manyraws *manyraw
*))
477 ;;; try a full GC, too
479 (with-test (:name
(:defstruct-raw-slot-gc
:full
))
480 (check-manyraws *manyraw
*))
482 (macrolet ((def-it ()
483 `(defstruct (huge-manyraw (:include manyraw
))
484 ,@(loop for n from
1 to
130
485 for s
= (write-to-string n
)
486 when
(zerop (random 10))
487 collect
`(,(sb-int:symbolicate
"WORD-SLOT-" s
)
488 ,n
:type sb-ext
:word
)
489 collect
`(,(sb-int:symbolicate
"SLOT-" s
) ,s
))
490 (df 8.207880688335944d-304
:type double-float
)
492 (sf 1.5679403e-38 :type single-float
)
493 (cdf #c
(9d0 -
2d10
) :type
(complex double-float
))
495 (csf #c
(2f1 2f0
) :type
(complex single-float
))
497 (w1 #xffee
:type sb-ext
:word
)
498 (w2 #xeeee
:type sb-ext
:word
))))
501 (defstruct (hugest-manyraw (:include huge-manyraw
))
502 (another-slot '(whocares)))
503 (defmethod make-load-form ((self hugest-manyraw
) &optional e
)
505 (make-load-form-saving-slots
508 ;; skip the slot named A so that the optimization that turns
509 ;; MAKE-LOAD-FORM-SAVING-SLOTS into "dump normally"
510 ;; (change 4bf626e745d5d2e34630ec4dd67b7c17bd9b8f28) can not be used.
511 (delete 'a
(mapcar 'sb-kernel
:dsd-name
513 (sb-kernel:find-defstruct-description
'hugest-manyraw
))))))
515 (defun check-huge-manyraw (s)
516 (assert (and (eql (huge-manyraw-df s
) 8.207880688335944d-304
)
517 (eql (huge-manyraw-aaa s
) 'aaa
)
518 (eql (huge-manyraw-sf s
) 1.5679403e-38)
519 (eql (huge-manyraw-cdf s
) #c
(9d0 -
2d10
))
520 (eql (huge-manyraw-bbb s
) 'bbb
)
521 (eql (huge-manyraw-csf s
) #c
(2f1 2f0
))
522 (eql (huge-manyraw-ccc s
) 'ccc
)
523 (eql (huge-manyraw-w1 s
) #xffee
)
524 (eql (huge-manyraw-w2 s
) #xeeee
)))
525 (dolist (slot (sb-kernel:dd-slots
526 (sb-kernel:layout-info
(sb-kernel:layout-of s
))))
527 (let ((name (string (sb-kernel:dsd-name slot
))))
528 (cond ((eql (mismatch name
"SLOT-") 5)
529 (let ((n (parse-integer name
:start
5)))
530 (assert (string= (funcall (sb-kernel:dsd-accessor-name slot
) s
)
531 (write-to-string n
)))))
532 ((eql (mismatch name
"WORD-SLOT-") 10)
533 (let ((n (parse-integer name
:start
10)))
534 (assert (= (funcall (sb-kernel:dsd-accessor-name slot
) s
)
537 ;;; fasl dumper and loader also have special handling of raw slots, so
538 ;;; dump all of them into a fasl
539 (defmethod make-load-form ((self manyraw
) &optional env
)
540 (make-load-form-saving-slots self
:environment env
))
541 (with-open-file (s "tmp-defstruct.manyraw.lisp"
543 :if-exists
:supersede
)
544 (write-string "(defun dumped-manyraws () '#.*manyraw*)" s
)
546 (write-string "(defun dumped-huge-manyraw () '#.(make-huge-manyraw))" s
)
547 (write-string "(defun dumped-hugest-manyraw () '#.(make-hugest-manyraw))" s
))
548 (compile-file "tmp-defstruct.manyraw.lisp")
549 (delete-file "tmp-defstruct.manyraw.lisp")
551 ;;; nuke the objects and try another GC just to be extra careful
555 ;;; re-read the dumped structures and check them
556 (load "tmp-defstruct.manyraw.fasl")
557 (with-test (:name
(:defstruct-raw-slot load
))
558 (check-manyraws (dumped-manyraws))
559 (check-huge-manyraw (make-huge-manyraw))
560 (assert (equalp (make-huge-manyraw) (dumped-huge-manyraw)))
561 ;; make-load-form omits slot A. it reads as 0
562 (assert (equalp (make-hugest-manyraw :a
0) (dumped-hugest-manyraw))))
565 ;;;; miscellaneous old bugs
567 (defstruct ya-struct
)
568 (when (ignore-errors (or (ya-struct-p) 12))
569 (error "YA-STRUCT-P of no arguments should signal an error."))
570 (when (ignore-errors (or (ya-struct-p 'too
'many
'arguments
) 12))
571 (error "YA-STRUCT-P of three arguments should signal an error."))
573 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
574 ;;; declared inside on the theory that slot types were already
575 ;;; checked, which bogusly suppressed unbound-variable and other
576 ;;; checks within the evaluation of initforms.
578 (defstruct (bug210a (:constructor bug210a
()))
582 ;;; Because of bug 210, this assertion used to fail.
583 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable
))
584 ;;; Even with bug 210, these assertions succeeded.
585 (assert (typep (nth-value 1 (ignore-errors *bug210
*)) 'unbound-variable
))
586 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable
))
588 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
589 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
590 ;;; setting up compiler-layout information would run before the
591 ;;; constructor function installing the layout was compiled. Make sure
592 ;;; that doesn't happen again.
593 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x
(y :not
)))
594 (assert (not (find-class 'foo-0-7-8-53 nil
)))
596 (assert (find-class 'foo-0-7-8-53 nil
))
597 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x
:s
)))
598 (assert (eq (foo-0-7-8-53-x foo-0-7-8-53
) :s
))
599 (assert (eq (foo-0-7-8-53-y foo-0-7-8-53
) :not
)))
601 ;;; tests of behaviour of colliding accessors.
602 (defstruct (bug127-foo (:conc-name bug127-baz-
)) a
)
603 (assert (= (bug127-baz-a (make-bug127-foo :a
1)) 1))
604 (defstruct (bug127-bar (:conc-name bug127-baz-
) (:include bug127-foo
)) b
)
605 (assert (= (bug127-baz-a (make-bug127-bar :a
1 :b
2)) 1))
606 (assert (= (bug127-baz-b (make-bug127-bar :a
1 :b
2)) 2))
607 (assert (= (bug127-baz-a (make-bug127-foo :a
1)) 1))
609 (defun bug127-flurble (x)
611 (defstruct bug127 flurble
)
612 (assert (= (bug127-flurble (make-bug127 :flurble
7)) 7))
614 (defstruct bug127-a b-c
)
615 (assert (= (bug127-a-b-c (make-bug127-a :b-c
9)) 9))
616 (defstruct (bug127-a-b (:include bug127-a
)) c
)
617 (assert (= (bug127-a-b-c (make-bug127-a :b-c
9)) 9))
618 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c
11 :c
13)) 11))
620 (defstruct (bug127-e (:conc-name bug127--
)) foo
)
621 (assert (= (bug127--foo (make-bug127-e :foo
3)) 3))
622 (defstruct (bug127-f (:conc-name bug127--
)) foo
)
623 (assert (= (bug127--foo (make-bug127-f :foo
3)) 3))
624 (assert-error (bug127--foo (make-bug127-e :foo
3)) type-error
)
626 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
628 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
630 (defstruct (conc-name-syntax :conc-name
) a-conc-name-slot
)
631 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot
'y
))
633 ;;; and further :CONC-NAME NIL was being wrongly treated:
634 (defpackage "DEFSTRUCT-TEST-SCRATCH")
635 (defstruct (conc-name-nil :conc-name
)
636 defstruct-test-scratch
::conc-name-nil-slot
)
637 (assert (= (defstruct-test-scratch::conc-name-nil-slot
638 (make-conc-name-nil :conc-name-nil-slot
1)) 1))
639 (assert-error (conc-name-nil-slot (make-conc-name-nil))
642 ;;; The named/typed predicates were a little fragile, in that they
643 ;;; could throw errors on innocuous input:
644 (defstruct (list-struct (:type list
) :named
) a-slot
)
645 (assert (list-struct-p (make-list-struct)))
646 (assert (not (list-struct-p nil
)))
647 (assert (not (list-struct-p 1)))
648 (defstruct (offset-list-struct (:type list
) :named
(:initial-offset
1)) a-slot
)
649 (assert (offset-list-struct-p (make-offset-list-struct)))
650 (assert (not (offset-list-struct-p nil
)))
651 (assert (not (offset-list-struct-p 1)))
652 (assert (not (offset-list-struct-p '(offset-list-struct))))
653 (assert (not (offset-list-struct-p '(offset-list-struct .
3))))
654 (defstruct (vector-struct (:type vector
) :named
) a-slot
)
655 (assert (vector-struct-p (make-vector-struct)))
656 (assert (not (vector-struct-p nil
)))
657 (assert (not (vector-struct-p #())))
660 ;;; bug 3d: type safety with redefined type constraints on slots
661 #+#.
(cl:if
(assertoid:legacy-eval-p
) '(or) '(and))
664 (let* ((base-name (intern (format nil
"bug3d-~A" type
)))
665 (up-name (intern (format nil
"~A-up" base-name
)))
666 (accessor (intern (format nil
"~A-X" base-name
)))
667 (up-accessor (intern (format nil
"~A-X" up-name
)))
668 (type-options (when type
`((:type
,type
)))))
670 (defstruct (,base-name
,@type-options
)
672 (defstruct (,up-name
(:include
,base-name
673 (x "x" :type simple-string
)
674 (y "y" :type simple-string
))
676 (let ((ob (,(intern (format nil
"MAKE-~A" up-name
)))))
677 (setf (,accessor ob
) 0)
678 (loop for decl in
'(inline notinline
)
679 for fun
= `(lambda (s)
680 (declare (optimize (safety 3))
681 (,decl
,',up-accessor
))
683 do
(assert-error (funcall (compile nil fun
) ob
)
689 (let* ((name (gensym))
690 (form `(defstruct ,name
691 (x nil
:type
(or null
(function (integer)
692 (values number
&optional foo
)))))))
693 (eval (copy-tree form
))
694 (eval (copy-tree form
)))
696 ;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
697 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
699 (defstruct (bug-332a (:type list
) (:initial-offset
5) :named
))
700 (defstruct (bug-332b (:type list
) (:initial-offset
2) :named
(:include bug-332a
)))
701 (assert (not (bug-332b-p (list* nil nil nil nil nil
'foo73 nil
'tail
))))
702 (assert (not (bug-332b-p 873257)))
703 (assert (not (bug-332b-p '(1 2 3 4 5 x
1 2 bug-332a
))))
704 (assert (bug-332b-p '(1 2 3 4 5 x
1 2 bug-332b
)))
706 ;;; Similar test for vectors, just for good measure.
707 (defstruct (bug-332a-aux (:type vector
)
708 (:initial-offset
5) :named
))
709 (defstruct (bug-332b-aux (:type vector
)
710 (:initial-offset
2) :named
711 (:include bug-332a-aux
)))
712 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x
1 premature-end
))))
713 (assert (not (bug-332b-aux-p 873257)))
714 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x
1 2 bug-332a-aux
))))
715 (assert (bug-332b-aux-p #(1 2 3 4 5 x
1 2 bug-332b-aux
)))
717 ;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
718 ;;; slot accessors signalled a condition at macroexpansion time, not
719 ;;; when the code was actually compiled or loaded.
720 (let ((defstruct-form '(defstruct bug-in-0-8-11-8 x
)))
721 (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
722 (handler-case (macroexpand defstruct-form
)
724 (error "shouldn't warn just from macroexpansion here"))))
726 ;;; bug 318 symptom no 1. (rest not fixed yet)
728 (handler-bind ((error (lambda (c)
729 ;; Used to cause stack-exhaustion
730 (unless (typep c
'storage-condition
)
734 (setf (find-class 'foo
) nil
)
735 (defstruct foo slot-1
)))))
737 ;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
739 (defstruct bug-348 x
)
741 (assert (eql -
1 (let ((i (eval '-
2))
743 (funcall #'(setf bug-348-x
)
745 (aref (vector x
) (incf i
)))
748 ;;; obsolete instance trapping
750 ;;; FIXME: Both error conditions below should possibly be instances
751 ;;; of the same class. (Putting this FIXME here, since this is the only
752 ;;; place where they appear together.)
754 (with-test (:name
:obsolete-defstruct
/print-object
)
755 (eval '(defstruct born-to-change
))
756 (let ((x (make-born-to-change)))
757 (handler-bind ((error 'continue
))
758 (eval '(defstruct born-to-change slot
)))
762 (sb-pcl::obsolete-structure
()
765 (with-test (:name
:obsolete-defstruct
/typep
)
766 (eval '(defstruct born-to-change-2
))
767 (let ((x (make-born-to-change-2)))
768 (handler-bind ((error 'continue
))
769 (eval '(defstruct born-to-change-2 slot
)))
772 (typep x
(find-class 'standard-class
))
773 (sb-kernel:layout-invalid
()
776 ;; EQUALP didn't work for structures with float slots (reported by
777 ;; Vjacheslav Fyodorov).
778 (defstruct raw-slot-equalp-bug
779 (b 0s0
:type single-float
)
781 (a 0d0
:type double-float
))
783 (defstruct raw-slot-equalp-bug-2
784 (b (complex 1d0
) :type
(complex double-float
))
785 (x (complex 1d0
) :type
(complex double-float
))
787 (a 1s0
:type single-float
))
789 (with-test (:name
:raw-slot-equalp
)
790 (assert (equalp (make-raw-slot-equalp-bug :a
1d0
:b
2s0
)
791 (make-raw-slot-equalp-bug :a
1d0
:b
2s0
)))
792 (assert (equalp (make-raw-slot-equalp-bug :a
1d0
:b
0s0
)
793 (make-raw-slot-equalp-bug :a
1d0
:b -
0s0
)))
794 (assert (not (equalp (make-raw-slot-equalp-bug :a
1d0
:b
2s0
)
795 (make-raw-slot-equalp-bug :a
1d0
:b
3s0
))))
796 (assert (not (equalp (make-raw-slot-equalp-bug :a
1d0
:b
2s0
)
797 (make-raw-slot-equalp-bug :a
2d0
:b
2s0
))))
798 (assert (equalp (make-raw-slot-equalp-bug-2 :b
(complex 1d0
) :a
2s0
)
799 (make-raw-slot-equalp-bug-2 :b
(complex 1d0
) :a
2s0
)))
800 (assert (equalp (make-raw-slot-equalp-bug-2 :b
(complex 1d0
) :a
0s0
)
801 (make-raw-slot-equalp-bug-2 :b
(complex 1d0
) :a -
0s0
)))
802 (assert (not (equalp (make-raw-slot-equalp-bug-2 :b
(complex 1d0
) :a
2s0
)
803 (make-raw-slot-equalp-bug-2 :b
(complex 1d0
) :a
3s0
))))
804 (assert (not (equalp (make-raw-slot-equalp-bug-2 :b
(complex 1d0
) :a
2s0
)
805 (make-raw-slot-equalp-bug-2 :b
(complex 2d0
) :a
2s0
)))))
807 ;;; Check that all slot types (non-raw and raw) can be initialized with
808 ;;; constant arguments.
809 (defstruct constant-arg-inits
812 (c 2 :type sb-vm
:word
)
813 (d 3.0 :type single-float
)
814 (e 4.0d0
:type double-float
)
815 (f #c
(5.0
5.0) :type
(complex single-float
))
816 (g #c
(6.0d0
6.0d0
) :type
(complex double-float
)))
817 (defun test-constant-arg-inits ()
818 (let ((foo (make-constant-arg-inits)))
819 (declare (dynamic-extent foo
))
820 (assert (eql 42 (constant-arg-inits-a foo
)))
821 (assert (eql 1 (constant-arg-inits-b foo
)))
822 (assert (eql 2 (constant-arg-inits-c foo
)))
823 (assert (eql 3.0 (constant-arg-inits-d foo
)))
824 (assert (eql 4.0d0
(constant-arg-inits-e foo
)))
825 (assert (eql #c
(5.0
5.0) (constant-arg-inits-f foo
)))
826 (assert (eql #c
(6.0d0
6.0d0
) (constant-arg-inits-g foo
)))))
827 (make-constant-arg-inits)
829 ;;; bug reported by John Morrison, 2008-07-22 on sbcl-devel
830 (defstruct (raw-slot-struct-with-unknown-init (:constructor make-raw-slot-struct-with-unknown-init
()))
831 (x (#:unknown-function
) :type double-float
))
833 ;;; Some checks for the behavior of incompatibly redefining structure
834 ;;; classes. We don't actually check that our detection of
835 ;;; "incompatible" is comprehensive, only that if an incompatible
836 ;;; definition is processed, we do various things.
837 (defmacro with-files
((&rest vars
) &body body
)
838 "Evaluate BODY with VARS bound to a number of filenames, then
839 delete the files at the end."
840 (let* ((paths (loop for var in vars
842 collect
(make-pathname
845 "DEFSTRUCT-REDEF-TEST-~D"
848 (binding-spec (mapcar
849 (lambda (var path
) `(,var
,path
)) vars paths
)))
856 (delete-file ,(elt paths n
))))))
858 ,@(frob (1- (length vars
)))))))
860 (defun noclobber (pathspec &rest forms
)
861 "Write FORMS to the file named by PATHSPEC, erroring if
862 PATHSPEC already names an existing file."
863 (with-open-file (*standard-output
* pathspec
:direction
:output
865 (print '(in-package "CL-USER"))
866 (mapc #'print forms
)))
868 (defun compile-file-assert (file &optional
(want-error-p t
) (want-warning-p t
))
869 "Compile FILE and assert some things about the results."
870 (multiple-value-bind (fasl errors-p warnings-p
)
873 (assert (eq errors-p want-error-p
))
874 (assert (eq warnings-p want-warning-p
))
877 (defun continue-from-incompatible-defstruct-error (error)
878 "Invoke the CONTINUE restart for an incompatible DEFSTRUCT
880 ;; FIXME: want distinct error type for incompatible defstruct.
881 (when (search "attempt to redefine" (simple-condition-format-control error
))
882 (when (find-restart 'continue
)
883 (invoke-restart 'continue
))))
885 (defun recklessly-continue-from-incompatible-defstruct-error (error)
886 "Invoke the RECKLESSLY-CONTINUE restart for an incompatible DEFSTRUCT
888 ;; FIXME: want distinct error type for incompatible defstruct.
889 (when (search "attempt to redefine" (simple-condition-format-control error
))
890 (when (find-restart 'sb-kernel
::recklessly-continue
)
891 (invoke-restart 'sb-kernel
::recklessly-continue
))))
893 (defun assert-is (predicate instance
)
894 (assert (funcall predicate instance
)))
896 ;;; It used to call the predicate function, but out-of-line predicate
897 ;;; functions now don't signal layout-invalid, just like inlined
898 ;;; predicates didn't signal it.
899 (defun assert-invalid (instance)
900 (declare (notinline typep
))
901 (assert (typep (nth-value 1 (ignore-errors (typep instance
'structure-object
)))
902 'sb-kernel
::layout-invalid
)))
904 ;; Don't try to understand this macro; just look at its expansion.
905 (defmacro with-defstruct-redefinition-test
(name
906 (&rest defstruct-form-bindings
)
907 (&rest path-form-specs
)
910 (labels ((make-defstruct-form (&key class-name super-name slots
)
911 (let* ((predicate-name
912 (read-from-string (format nil
"~A-p" class-name
)))
914 (read-from-string (format nil
"make-~A" class-name
))))
916 '(defstruct (,class-name
917 (:constructor
,constructor-name
)
919 `((:include
,super-name
))))
923 (frob (bindspecs classno
)
925 `((multiple-value-bind ,(first (first bindspecs
))
926 ,(apply #'make-defstruct-form
(rest (first bindspecs
)))
927 (declare (ignorable ,@(first (first bindspecs
))))
928 ,@(frob (rest bindspecs
) (1+ classno
))))
929 `((with-files ,(mapcar #'first path-form-specs
)
930 ,@(mapcar (lambda (path-form) `(noclobber ,@path-form
))
933 ((simple-error ',handler-function
))
935 `(with-test (:name
,name
)
936 ,(first (frob defstruct-form-bindings
0)))))
938 ;; When eyeballing these, it's helpful to see when various things are
940 (setq *compile-verbose
* t
*load-verbose
* t
)
943 ;; Base case: recklessly-continue.
944 (with-defstruct-redefinition-test :defstruct
/recklessly
945 (((defstruct ctor pred
) :class-name redef-test-1
:slots
(a))
946 ((defstruct*) :class-name redef-test-1
:slots
(a b
)))
949 recklessly-continue-from-incompatible-defstruct-error
951 (let ((instance (funcall ctor
)))
953 (assert-is pred instance
)))
955 ;; Base case: continue (i.e., invalidate instances).
956 (with-defstruct-redefinition-test :defstruct
/continue
957 (((defstruct ctor
) :class-name redef-test-2
:slots
(a))
958 ((defstruct*) :class-name redef-test-2
:slots
(a b
)))
961 continue-from-incompatible-defstruct-error
963 (let ((instance (funcall ctor
)))
965 (assert-invalid instance
)))
967 ;; Compiling a file with an incompatible defstruct should emit a
968 ;; warning and an error, but the fasl should be loadable.
969 (with-defstruct-redefinition-test :defstruct
/compile-file-should-warn
970 (((defstruct) :class-name redef-test-3
:slots
(a))
971 ((defstruct*) :class-name redef-test-3
:slots
(a b
)))
974 continue-from-incompatible-defstruct-error
976 (load (compile-file-assert path2
)))
978 ;; After compiling a file with an incompatible DEFSTRUCT, load the
979 ;; fasl and ensure that an old instance remains valid.
980 (with-defstruct-redefinition-test :defstruct
/compile-file-reckless
981 (((defstruct ctor pred
) :class-name redef-test-4
:slots
(a))
982 ((defstruct*) :class-name redef-test-4
:slots
(a b
)))
985 recklessly-continue-from-incompatible-defstruct-error
987 (let ((instance (funcall ctor
)))
988 (load (compile-file-assert path2
))
989 (assert-is pred instance
)))
991 ;; After compiling a file with an incompatible DEFSTRUCT, load the
992 ;; fasl and ensure that an old instance has become invalid.
993 (with-defstruct-redefinition-test :defstruct
/compile-file-continue
994 (((defstruct ctor
) :class-name redef-test-5
:slots
(a))
995 ((defstruct*) :class-name redef-test-5
:slots
(a b
)))
998 continue-from-incompatible-defstruct-error
1000 (let ((instance (funcall ctor
)))
1001 (load (compile-file-assert path2
))
1002 (assert-invalid instance
)))
1005 ;; Ensure that recklessly continuing DT(expected)T to instances of
1006 ;; subclasses. (This is a case where recklessly continuing is
1007 ;; actually dangerous, but we don't care.)
1008 (with-defstruct-redefinition-test :defstruct
/subclass-reckless
1009 (((defstruct ignore pred1
) :class-name redef-test-6
:slots
(a))
1010 ((substruct ctor pred2
) :class-name redef-test-6-sub
1011 :super-name redef-test-6
:slots
(z))
1012 ((defstruct*) :class-name redef-test-6
:slots
(a b
)))
1013 ((path1 defstruct substruct
)
1014 (path2 defstruct
* substruct
))
1015 recklessly-continue-from-incompatible-defstruct-error
1017 (let ((instance (funcall ctor
)))
1018 (load (compile-file-assert path2
))
1019 (assert-is pred1 instance
)
1020 (assert-is pred2 instance
)))
1022 ;; Ensure that continuing invalidates instances of subclasses.
1023 (with-defstruct-redefinition-test :defstruct
/subclass-continue
1024 (((defstruct) :class-name redef-test-7
:slots
(a))
1025 ((substruct ctor
) :class-name redef-test-7-sub
1026 :super-name redef-test-7
:slots
(z))
1027 ((defstruct*) :class-name redef-test-7
:slots
(a b
)))
1028 ((path1 defstruct substruct
)
1029 (path2 defstruct
* substruct
))
1030 continue-from-incompatible-defstruct-error
1032 (let ((instance (funcall ctor
)))
1033 (load (compile-file-assert path2
))
1034 (assert-invalid instance
)))
1036 ;; Reclkessly continuing doesn't invalidate instances of subclasses.
1037 (with-defstruct-redefinition-test :defstruct
/subclass-in-other-file-reckless
1038 (((defstruct ignore pred1
) :class-name redef-test-8
:slots
(a))
1039 ((substruct ctor pred2
) :class-name redef-test-8-sub
1040 :super-name redef-test-8
:slots
(z))
1041 ((defstruct*) :class-name redef-test-8
:slots
(a b
)))
1045 recklessly-continue-from-incompatible-defstruct-error
1048 (let ((instance (funcall ctor
)))
1049 (load (compile-file-assert path3
))
1050 (assert-is pred1 instance
)
1051 (assert-is pred2 instance
)))
1053 ;; This is an icky case: when a subclass is defined in a separate
1054 ;; file, CONTINUE'ing from LOAD of a file containing an incompatible
1055 ;; superclass definition leaves the predicates and accessors into the
1056 ;; subclass in a bad way until the subclass form is evaluated.
1057 (with-defstruct-redefinition-test :defstruct
/subclass-in-other-file-continue
1058 (((defstruct ignore
) :class-name redef-test-9
:slots
(a))
1059 ((substruct ctor
) :class-name redef-test-9-sub
1060 :super-name redef-test-9
:slots
(z))
1061 ((defstruct*) :class-name redef-test-9
:slots
(a b
)))
1065 continue-from-incompatible-defstruct-error
1068 (let ((instance (funcall ctor
)))
1069 (load (compile-file-assert path3
))
1070 ;; At this point, the instance of the subclass will not count as
1071 ;; an instance of the superclass or of the subclass, but PRED2's
1072 ;; predicate will error with "an obsolete structure accessor
1073 ;; function was called".
1074 (assert-invalid instance
)
1075 (format t
"~&~A~%" (nth-value 1 (ignore-errors (funcall pred2 instance
))))
1076 ;; After loading PATH2, we'll get the desired LAYOUT-INVALID error.
1078 (assert-invalid instance
)))
1080 ;; Some other subclass wrinkles have to do with splitting definitions
1081 ;; accross files and compiling and loading things in a funny order.
1082 (with-defstruct-redefinition-test
1083 :defstruct
/subclass-in-other-file-funny-operation-order-continue
1084 (((defstruct ignore pred1
) :class-name redef-test-10
:slots
(a))
1085 ((substruct ctor pred2
) :class-name redef-test-10-sub
1086 :super-name redef-test-10
:slots
(z))
1087 ((defstruct*) :class-name redef-test-10
:slots
(a b
)))
1091 continue-from-incompatible-defstruct-error
1094 (let ((instance (funcall ctor
)))
1095 ;; First we clobber the compiler's layout for the superclass.
1096 (compile-file-assert path3
)
1097 ;; Then we recompile the subclass definition (which generates a
1098 ;; warning about the compiled layout for the superclass being
1099 ;; incompatible with the loaded layout, because we haven't loaded
1100 ;; path3 since recompiling).
1101 (compile-file path2
)
1102 ;; Ugh. I don't want to think about loading these in the wrong
1104 (load (compile-file-pathname path3
))
1105 (load (compile-file-pathname path2
))
1106 (assert-invalid instance
)
1107 (assert-invalid instance
)))
1109 (with-defstruct-redefinition-test
1110 :defstruct
/subclass-in-other-file-funny-operation-order-continue
1111 (((defstruct ignore pred1
) :class-name redef-test-11
:slots
(a))
1112 ((substruct ctor pred2
) :class-name redef-test-11-sub
1113 :super-name redef-test-11
:slots
(z))
1114 ((defstruct*) :class-name redef-test-11
:slots
(a b
)))
1118 continue-from-incompatible-defstruct-error
1121 (let ((instance (funcall ctor
)))
1122 ;; This clobbers the compiler's layout for REDEF-TEST-11.
1123 (compile-file-assert path3
)
1124 ;; This recompiles REDEF-TEST-11-SUB, using the new REDEF-TEST-11
1126 (load (compile-file-pathname path2
))
1127 ;; Note that because we haven't loaded PATH3, we haven't clobbered
1128 ;; the class's layout REDEF-TEST-11, so REDEF-11's predicate will
1129 ;; still work. That's probably bad.
1130 (assert-is pred1 instance
)
1131 (assert-is pred2 instance
)))
1133 (with-test (:name
:raw-slot
/circle-subst
)
1134 ;; CIRCLE-SUBSTS used %INSTANCE-REF on raw slots
1135 (multiple-value-bind (list n
)
1137 (defstruct raw-slot
/circle-subst
1138 (x 0.0 :type single-float
))
1139 (read-from-string "((#1=#S(raw-slot/circle-subst :x 2.7158911)))")))
1140 (destructuring-bind ((struct)) list
1141 (assert (raw-slot/circle-subst-p struct
))
1142 (assert (eql 2.7158911 (raw-slot/circle-subst-x struct
)))
1143 (assert (eql 45 n
)))))
1145 (defstruct (bug-3b (:constructor make-bug-3b
(&aux slot
)))
1146 (slot nil
:type string
))
1148 (with-test (:name
:bug-3b
)
1151 (bug-3b-slot (make-bug-3b))
1154 (assert (eq 'string
(type-error-expected-type e
)))
1155 (assert (zerop (type-error-datum e
))))))
1157 (with-test (:name
:defstruct-copier-typechecks-argument
)
1158 (copy-person (make-astronaut :name
"Neil"))
1159 (assert-error (copy-astronaut (make-person :name
"Fred"))))
1161 (with-test (:name
:bug-528807
)
1162 (let ((*evaluator-mode
* :compile
))
1163 (handler-bind ((style-warning #'error
))
1164 (eval `(defstruct (bug-528807 (:constructor make-528807
(&aux x
)))
1165 (x nil
:type fixnum
))))))
1167 (with-test (:name
:bug-520607
)
1169 (eval '(defstruct (typed-struct (:type list
) (:predicate typed-struct-p
))
1170 (a 42 :type fixnum
))))
1171 ;; NIL is ok, though.
1172 (eval '(defstruct (typed-struct (:type list
) (:predicate nil
))
1173 (a 42 :type fixnum
)))
1175 ;; (:predicate) is not ok because absence of the argument does not mean
1176 ;; that the value of the option is NIL, as it must be for :typed un-:named.
1178 ;; This option takes one argument ...
1179 ;; If the argument is not supplied ... the name of the predicate is made
1180 ;; by concatenating the name of the structure to the string "-P"
1181 ;; If the argument is provided and is nil, no predicate is defined.
1182 ;; ... if :type is supplied and :named is not supplied, then :predicate
1183 ;; must either be unsupplied or have the value nil."
1185 ;; The last piece says that the entire option must be unsupplied
1186 ;; or else "have the value NIL", and is preceded by a description of the
1187 ;; precise manner in which absence of an argument is not the same as nil.
1190 (eval '(defstruct (typed-struct2 (:type list
) (:predicate
))
1191 (a 42 :type fixnum
)))))
1193 (with-test (:name
(:boa-supplied-p
&optional
))
1194 (handler-bind ((sb-c:inlining-dependency-failure
#'muffle-warning
)
1196 (eval `(defstruct (boa-supplied-p.1 (:constructor make-boa-supplied-p
.1
1197 (&optional
(bar t barp
))))
1200 (let ((b1 (make-boa-supplied-p.1))
1201 (b2 (make-boa-supplied-p.1 t
)))
1202 (assert (eq t
(boa-supplied-p.1-bar b1
)))
1203 (assert (eq t
(boa-supplied-p.1-bar b2
)))
1204 (assert (eq nil
(boa-supplied-p.1-barp b1
)))
1205 (assert (eq t
(boa-supplied-p.1-barp b2
)))))
1207 (with-test (:name
(:boa-supplied-p
&key
))
1208 (handler-bind ((sb-c:inlining-dependency-failure
#'muffle-warning
)
1210 (eval `(defstruct (boa-supplied-p.2 (:constructor make-boa-supplied-p
.2
1211 (&key
(bar t barp
))))
1214 (let ((b1 (make-boa-supplied-p.2))
1215 (b2 (make-boa-supplied-p.2 :bar t
)))
1216 (assert (eq t
(boa-supplied-p.2-bar b1
)))
1217 (assert (eq t
(boa-supplied-p.2-bar b2
)))
1218 (assert (eq nil
(boa-supplied-p.2-barp b1
)))
1219 (assert (eq t
(boa-supplied-p.2-barp b2
)))))
1221 (defstruct structure-with-predicate
)
1222 (defclass class-to-be-redefined
() ())
1223 (let ((x (make-instance 'class-to-be-redefined
)))
1224 (defun function-trampoline (fun) (funcall fun x
)))
1226 (with-test (:name
(:struct-predicate
:obsolete-instance
))
1227 (defclass class-to-be-redefined
() ((a :initarg
:a
:initform
1)))
1228 (function-trampoline #'structure-with-predicate-p
))
1230 (with-test (:name
(:defstruct
:not-toplevel-silent
))
1231 (let ((sb-ext:*evaluator-mode
* :compile
))
1232 (handler-bind ((warning #'error
))
1234 (defstruct defstruct-no-warning-not-at-toplevel bar
))))))
1236 (with-test (:name
:bug-941102
)
1237 (let ((test `((defstruct bug-941102
)
1238 (setf (find-class 'bug-941102-alias
) (find-class 'bug-941102
))
1239 (setf (find-class 'bug-941102-alias
) nil
))))
1240 (multiple-value-bind (warn fail
) (ctu:file-compile test
:load t
)
1242 (assert (not fail
)))
1243 (multiple-value-bind (warn2 fail2
) (ctu:file-compile test
)
1244 (assert (not warn2
))
1245 (assert (not fail2
)))))
1247 (with-test (:name
(:defstruct
:constant-slot-names
))
1248 (defstruct defstruct-constant-slot-names t
)
1249 (assert (= 3 (defstruct-constant-slot-names-t
1250 (make-defstruct-constant-slot-names :t
3)))))
1252 (with-test (:name
(:defstruct
:bogus-inherited-slot-specs
))
1253 (defstruct flopsie a b c
)
1255 (handler-case (macroexpand '(defstruct (mopsie (:include flopsie
(a 3) (z 9))) q
))
1257 (search "slot name Z not present" (write-to-string c
:escape nil
)))
1258 (:no-error
(x) x nil
)))
1260 (handler-case (macroexpand '(defstruct (mopsie (:include flopsie
(a 3) (a 'a
))) q
))
1262 (search "slot name A specified more than once" (write-to-string c
:escape nil
)))
1263 (:no-error
(x) x nil
))))
1266 (defstruct bogus-aux
.1 (:constructor make-bogus-aux
.1 (&aux
(a b c
)))))
1268 (with-test (:name
(:defstruct
:lexical-default
))
1269 (let ((x 0)) (defstruct lexical-default
(a (incf x
)))
1270 (assert (= (lexical-default-a (make-lexical-default))
1274 (with-test (:name
(:defstruct
:find-defstruct-description
))
1275 (assert (null (sb-kernel:find-defstruct-description
'not-foo nil
)))
1277 (assert-error (sb-kernel:find-defstruct-description
'not-foo t
)))
1279 (defstruct (a-named-struct :named
(:type vector
)) a b c
)
1280 (defstruct (a-kid-struct :named
(:type vector
) (:include a-named-struct
)) n
)
1281 (with-test (:name
(:defstruct
:named-typed-struct-subtype-pred
))
1282 (let ((par (make-a-named-struct :b
6))
1283 (kid (make-a-kid-struct :n
5)))
1284 (assert (a-named-struct-p par
))
1285 (assert (a-named-struct-p kid
))
1286 (assert (not (a-kid-struct-p par
)))
1287 (assert (a-kid-struct-p kid
))))
1289 (with-test (:name
:defstruct-parse-strictly
)
1291 '((defstruct (s :conc-name
(:conc-name b1-
)) x y
)
1292 (defstruct (s :copier
:copier
) x y
)
1293 (defstruct (s (:include
) (:include
)) x y
)
1294 (defstruct (s (:initial-offset
2) (:initial-offset nil
)) x y
)
1295 (defstruct (s (:predicate nil
) (:predicate foolp
)) x y
)
1296 (defstruct (s (:type list
) (:type vector
)) x y
)
1297 ;; The :NAMED option requires that SYMBOL be a subtype of the
1298 ;; *supplied* element type (not the upgraded element-type).
1299 ;; Defining a subtype of the structure places another symbol in
1300 ;; the vector, and we can't anticipate what that will be.
1301 ;; [Though in practice it is somewhere between unlikely and
1302 ;; impossible that an implementation would be able to specialize
1303 ;; on only one particular symbol and not also allow any symbol]
1304 (defstruct (s (:type
(vector (or (eql s
) integer
))) :named
) x y
)
1306 (assert-error (macroexpand form
))))
1308 (defstruct (foo-not-too-something
1309 (:constructor make-foo-not-too-strong
(x &aux
(x (abs x
))))
1310 (:constructor make-foo-not-too-weak
(&optional x
)))
1311 (x nil
:type unsigned-byte
))
1313 (with-test (:name
:defstruct-ftype-correctness
)
1314 (assert (make-foo-not-too-strong -
3)) ; should be allowed
1315 (assert-error (make-foo-not-too-weak))) ; should not set X slot to NIL
1317 (defstruct fruitbat a
(b #xbadf00d
:type sb-ext
:word
) (c 'hi
))
1318 (mapc 'fmakunbound
'(fruitbat-a fruitbat-b fruitbat-c
))
1319 (with-test (:name
:defstruct-printer-robust
)
1320 (assert (string= (princ-to-string (make-fruitbat :a
"test"))
1321 "#S(FRUITBAT :A test :B 195948557 :C HI)")))
1325 (with-test (:name
:redefine-accessor-as-random-defun
)
1326 (flet ((assert-that (expect form
)
1327 ;; test by STRING= since there's no condition class,
1328 ;; being a little more thorough than merely ASSERT-SIGNAL.
1330 (handler-bind ((simple-warning
1332 (when (string= (princ-to-string c
) expect
)
1334 (muffle-warning)))))
1337 (assert-that "redefinition of X-Y clobbers structure accessor"
1338 '(defun x-y (z) (list :x-y z
)))
1339 (assert-that "redefinition of X-P clobbers structure predicate"
1340 '(defun x-p (z) (list 'bork z
))))
1342 (funcall (compile nil
'(lambda (z) (x-y z
)))
1344 '(:X-Y
#S
(X :Y T
))))
1346 (funcall (compile nil
'(lambda (z)
1347 (declare (notinline x-y
))
1350 '(:X-Y
#S
(X :Y T
)))))
1352 (in-package sb-kernel
)
1354 ;; The word order for halves of double-floats on 32-bit platforms
1355 ;; should match the platform's native order.
1356 (defun compare-memory (obj1 obj1-word-ofs obj2 obj2-word-ofs n-words
)
1357 (with-pinned-objects (obj1 obj2
)
1358 (let ((sap1 (int-sap (- (get-lisp-obj-address obj1
) (lowtag-of obj1
))))
1359 (sap2 (int-sap (- (get-lisp-obj-address obj2
) (lowtag-of obj2
)))))
1360 (dotimes (i n-words
)
1361 (let ((w1 (sap-ref-32 sap1
(ash (+ obj1-word-ofs i
) sb-vm
:word-shift
)))
1362 (w2 (sap-ref-32 sap2
(ash (+ obj2-word-ofs i
) sb-vm
:word-shift
))))
1363 (assert (= w1 w2
)))))))
1365 (defstruct struct-df
(a pi
:type double-float
))
1366 (defvar *c
* (complex (exp 1d0
) pi
))
1367 (defstruct struct-cdf
(a *c
* :type
(complex double-float
)))
1369 (defvar *adf
* (make-array 1 :element-type
'double-float
1370 :initial-element pi
))
1371 (defvar *acdf
* (make-array 1 :element-type
'(complex double-float
)
1372 :initial-element
*c
*))
1374 (test-util:with-test
(:name
:dfloat-endianness
1375 :skipped-on
'(not (or :mips
:x86
))) ; only tested on these
1376 (compare-memory pi
2 *adf
* 2 2) ; Array
1377 (compare-memory pi
2 (make-struct-df) 2 2) ; Structure
1379 (compare-memory *c
* 2 *acdf
* 2 4) ; Array
1380 (compare-memory *c
* 2 (make-struct-cdf) 2 4)) ; Structure