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 (cl:in-package
:cl-user
)
14 (load "assertoid.lisp")
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
23 (assert (raises-error?
(make-person) type-error
))
24 ;;; FIXME: broken structure slot type checking in sbcl-0.pre7.62
25 #+nil
(assert (raises-error?
(setf (person-name (make-person "Q")) 1) type-error
))
28 (defstruct (astronaut (:include person
)
31 (favorite-beverage 'tang
))
32 (let ((x (make-astronaut :name
"Buzz" :helmet-size
17.5)))
33 (assert (equal (person-name x
) "Buzz"))
34 (assert (equal (astro-name x
) "Buzz"))
35 (assert (eql (astro-favorite-beverage x
) 'tang
))
36 (assert (null (astro-age x
))))
37 (defstruct (ancient-astronaut (:include person
(age 77)))
39 (favorite-beverage 'tang
))
40 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name
"John")) 77))
42 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
43 (defstruct (binop (:type list
) :named
(:initial-offset
2))
44 (operator '?
:type symbol
)
47 (defstruct (annotated-binop (:type list
)
50 commutative associative identity
)
51 (assert (equal (make-annotated-binop :operator
'*
57 '(nil nil binop
* x
5 nil nil nil t t
1)))
59 ;;; effect of :NAMED on :TYPE
60 (defstruct (named-binop (:type list
) :named
)
61 (operator '?
:type symbol
)
64 (let ((named-binop (make-named-binop :operator
'+ :operand-1
'x
:operand-2
5)))
65 ;; The data representation is specified to look like this.
66 (assert (equal named-binop
'(named-binop + x
5)))
67 ;; A meaningful NAMED-BINOP-P is defined.
68 (assert (named-binop-p named-binop
))
69 (assert (named-binop-p (copy-list named-binop
)))
70 (assert (not (named-binop-p (cons 11 named-binop
))))
71 (assert (not (named-binop-p (find-package :cl
)))))
77 (firetrucks 1 :type fixnum
)
79 (elevation 5128 :read-only t
))
80 (let ((town1 (make-town :area
0 :watertowers
0)))
81 (assert (town-p town1
))
82 (assert (not (town-p 1)))
83 (assert (eql (town-area town1
) 0))
84 (assert (eql (town-elevation town1
) 5128))
85 (assert (null (town-population town1
)))
86 (setf (town-population town1
) 99)
87 (assert (eql (town-population town1
) 99))
88 (let ((town2 (copy-town town1
)))
89 (dolist (slot-accessor-name '(town-area
94 (assert (eql (funcall slot-accessor-name town1
)
95 (funcall slot-accessor-name town2
))))
96 (assert (not (fboundp '(setf town-elevation
)))))) ; 'cause it's :READ-ONLY
99 (defstruct (clown (:conc-name bozo-
))
103 (let ((funny-clown (make-clown)))
104 (assert (eql (bozo-nose-color funny-clown
) 'red
)))
105 (defstruct (klown (:constructor make-up-klown
)
106 (:copier clone-klown
)
107 (:predicate is-a-bozo-p
))
111 (assert (is-a-bozo-p (make-up-klown)))
113 ;;;; systematically testing variants of DEFSTRUCT:
114 ;;;; * native, :TYPE LIST, and :TYPE VECTOR
116 ;;; FIXME: things to test:
117 ;;; * Slot readers work.
118 ;;; * Slot writers work.
119 ;;; * Predicates work.
121 ;;; FIXME: things that would be nice to test systematically someday:
122 ;;; * constructors (default, boa..)
124 ;;; * no type checks when (> SPEED SAFETY)
125 ;;; * Tests of inclusion would be good. (It's tested very lightly
126 ;;; above, and then tested a fair amount by the system compiling
129 (defun string+ (&rest rest
)
130 (apply #'concatenate
'string
131 (mapcar #'string rest
)))
132 (defun symbol+ (&rest rest
)
133 (values (intern (apply #'string
+ rest
))))
135 (defun accessor-name (conc-name slot-name
)
136 (symbol+ conc-name slot-name
))
138 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
139 ;;; to read and write a structure slot.
140 (defun read-slot-notinline (conc-name slot-name instance
)
141 (funcall (accessor-name conc-name slot-name
) instance
))
142 (defun write-slot-notinline (new-value conc-name slot-name instance
)
143 (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name
)))
146 ;;; Use inline expansions of slot accessors, if possible, to read and
147 ;;; write a structure slot.
148 (defun read-slot-inline (conc-name slot-name instance
)
149 (funcall (compile nil
151 (,(accessor-name conc-name slot-name
) instance
)))
153 (defun write-slot-inline (new-value conc-name slot-name instance
)
154 (funcall (compile nil
155 `(lambda (new-value instance
)
156 (setf (,(accessor-name conc-name slot-name
) instance
)
161 ;;; Read a structure slot, checking that the inline and out-of-line
162 ;;; accessors give the same result.
163 (defun read-slot (conc-name slot-name instance
)
164 (let ((inline-value (read-slot-inline conc-name slot-name instance
))
165 (notinline-value (read-slot-notinline conc-name slot-name instance
)))
166 (assert (eql inline-value notinline-value
))
169 ;;; Write a structure slot, using INLINEP argument to decide
170 ;;; on inlineness of accessor used.
171 (defun write-slot (new-value conc-name slot-name instance inlinep
)
173 (write-slot-inline new-value conc-name slot-name instance
)
174 (write-slot-notinline new-value conc-name slot-name instance
)))
176 ;;; bound during the tests so that we can get to it even if the
177 ;;; debugger is having a bad day
180 (defmacro test-variant
(defstructname &key colontype boa-constructor-p
)
183 (format t
"~&/beginning PROGN for COLONTYPE=~S~%" ',colontype
)
185 (defstruct (,defstructname
186 ,@(when colontype
`((:type
,colontype
)))
187 ,@(when boa-constructor-p
188 `((:constructor
,(symbol+ "CREATE-" defstructname
)
191 (optional-test 2 optional-test-p
)
194 (no-home-comment "Home package CL not provided.")
195 (comment (if home-p
"" no-home-comment
))
196 (refcount (if optional-test-p optional-test nil
))
200 ;; some ordinary tagged slots
202 (home nil
:type package
:read-only t
)
203 (comment "" :type simple-string
)
205 (weight 1.0 :type single-float
)
206 (hash 1 :type
(integer 1 #.
(* 3 most-positive-fixnum
)) :read-only t
)
207 ;; more ordinary tagged slots
208 (refcount 0 :type
(and unsigned-byte fixnum
)))
210 (format t
"~&/done with DEFSTRUCT~%")
212 (let* ((cn (string+ ',defstructname
"-")) ; conc-name
213 (ctor (symbol-function ',(symbol+ (if boa-constructor-p
217 (*instance
* (funcall ctor
218 ,@(unless boa-constructor-p
220 ,@(when boa-constructor-p
222 :home
(find-package :cl
)
223 :hash
(+ 14 most-positive-fixnum
)
224 ,@(unless boa-constructor-p
227 ;; Check that ctor set up slot values correctly.
228 (format t
"~&/checking constructed structure~%")
229 (assert (string= "some id" (read-slot cn
"ID" *instance
*)))
230 (assert (eql (find-package :cl
) (read-slot cn
"HOME" *instance
*)))
231 (assert (string= "" (read-slot cn
"COMMENT" *instance
*)))
232 (assert (= 1.0 (read-slot cn
"WEIGHT" *instance
*)))
233 (assert (eql (+ 14 most-positive-fixnum
)
234 (read-slot cn
"HASH" *instance
*)))
235 (assert (= 1 (read-slot cn
"REFCOUNT" *instance
*)))
237 ;; There should be no writers for read-only slots.
238 (format t
"~&/checking no read-only writers~%")
239 (assert (not (fboundp `(setf ,(symbol+ cn
"HOME")))))
240 (assert (not (fboundp `(setf ,(symbol+ cn
"HASH")))))
241 ;; (Read-only slot values are checked in the loop below.)
243 (dolist (inlinep '(t nil
))
244 (format t
"~&/doing INLINEP=~S~%" inlinep
)
245 ;; Fiddle with writable slot values.
246 (let ((new-id (format nil
"~S" (random 100)))
247 (new-comment (format nil
"~X" (random 5555)))
248 (new-weight (random 10.0)))
249 (write-slot new-id cn
"ID" *instance
* inlinep
)
250 (write-slot new-comment cn
"COMMENT" *instance
* inlinep
)
251 (write-slot new-weight cn
"WEIGHT" *instance
* inlinep
)
252 (assert (eql new-id
(read-slot cn
"ID" *instance
*)))
253 (assert (eql new-comment
(read-slot cn
"COMMENT" *instance
*)))
254 ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
255 ;; (error "WEIGHT mismatch: ~S vs. ~S"
256 ;; new-weight (read-slot cn "WEIGHT" *instance*)))
257 (assert (eql new-weight
(read-slot cn
"WEIGHT" *instance
*)))))
258 (format t
"~&/done with INLINEP loop~%")
260 ;; :TYPE FOO objects don't go in the Lisp type system, so we
261 ;; can't test TYPEP stuff for them.
263 ;; FIXME: However, when they're named, they do define
264 ;; predicate functions, and we could test those.
266 `(;; Fiddle with predicate function.
267 (let ((pred-name (symbol+ ',defstructname
"-P")))
268 (format t
"~&/doing tests on PRED-NAME=~S~%" pred-name
)
269 (assert (funcall pred-name
*instance
*))
270 (assert (not (funcall pred-name
14)))
271 (assert (not (funcall pred-name
"test")))
272 (assert (not (funcall pred-name
(make-hash-table))))
274 (compile nil
`(lambda (x) (,pred-name x
)))))
275 (format t
"~&/doing COMPILED-PRED tests~%")
276 (assert (funcall compiled-pred
*instance
*))
277 (assert (not (funcall compiled-pred
14)))
278 (assert (not (funcall compiled-pred
#()))))
279 ;; Fiddle with TYPEP.
280 (format t
"~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype
)
281 (assert (typep *instance
* ',defstructname
))
282 (assert (not (typep 0 ',defstructname
)))
283 (assert (funcall (symbol+ "TYPEP") *instance
* ',defstructname
))
284 (assert (not (funcall (symbol+ "TYPEP") nil
',defstructname
)))
285 (let* ((typename ',defstructname
)
287 (compile nil
`(lambda (x) (typep x
',typename
)))))
288 (assert (funcall compiled-typep
*instance
*))
289 (assert (not (funcall compiled-typep nil
))))))))
291 (format t
"~&/done with PROGN for COLONTYPE=~S~%" ',colontype
)))
293 (test-variant vanilla-struct
)
294 (test-variant vector-struct
:colontype vector
)
295 (test-variant list-struct
:colontype list
)
296 (test-variant vanilla-struct
:boa-constructor-p t
)
297 (test-variant vector-struct
:colontype vector
:boa-constructor-p t
)
298 (test-variant list-struct
:colontype list
:boa-constructor-p t
)
301 ;;;; testing raw slots harder
303 ;;;; The offsets of raw slots need to be rescaled during the punning
304 ;;;; process which is used to access them. That seems like a good
305 ;;;; place for errors to lurk, so we'll try hunting for them by
306 ;;;; verifying that all the raw slot data gets written successfully
307 ;;;; into the object, can be copied with the object, and can then be
308 ;;;; read back out (with none of it ending up bogusly outside the
309 ;;;; object, so that it couldn't be copied, or bogusly overwriting
310 ;;;; some other raw slot).
313 (a (expt 2 30) :type
(unsigned-byte 32))
314 (b 0.1 :type single-float
)
315 (c 0.2d0
:type double-float
)
316 (d #c
(0.3
0.3) :type
(complex single-float
))
317 unraw-slot-just-for-variety
318 (e #c
(0.4d0
0.4d0
) :type
(complex double-float
))
319 (aa (expt 2 30) :type
(unsigned-byte 32))
320 (bb 0.1 :type single-float
)
321 (cc 0.2d0
:type double-float
)
322 (dd #c
(0.3
0.3) :type
(complex single-float
))
323 (ee #c
(0.4d0
0.4d0
) :type
(complex double-float
)))
325 (defvar *manyraw
* (make-manyraw))
327 (assert (eql (manyraw-a *manyraw
*) (expt 2 30)))
328 (assert (eql (manyraw-b *manyraw
*) 0.1))
329 (assert (eql (manyraw-c *manyraw
*) 0.2d0
))
330 (assert (eql (manyraw-d *manyraw
*) #c
(0.3
0.3)))
331 (assert (eql (manyraw-e *manyraw
*) #c
(0.4d0
0.4d0
)))
332 (assert (eql (manyraw-aa *manyraw
*) (expt 2 30)))
333 (assert (eql (manyraw-bb *manyraw
*) 0.1))
334 (assert (eql (manyraw-cc *manyraw
*) 0.2d0
))
335 (assert (eql (manyraw-dd *manyraw
*) #c
(0.3
0.3)))
336 (assert (eql (manyraw-ee *manyraw
*) #c
(0.4d0
0.4d0
)))
338 (setf (manyraw-aa *manyraw
*) (expt 2 31)
339 (manyraw-bb *manyraw
*) 0.11
340 (manyraw-cc *manyraw
*) 0.22d0
341 (manyraw-dd *manyraw
*) #c
(0.33
0.33)
342 (manyraw-ee *manyraw
*) #c
(0.44d0
0.44d0
))
344 (let ((copy (copy-manyraw *manyraw
*)))
345 (assert (eql (manyraw-a copy
) (expt 2 30)))
346 (assert (eql (manyraw-b copy
) 0.1))
347 (assert (eql (manyraw-c copy
) 0.2d0
))
348 (assert (eql (manyraw-d copy
) #c
(0.3
0.3)))
349 (assert (eql (manyraw-e copy
) #c
(0.4d0
0.4d0
)))
350 (assert (eql (manyraw-aa copy
) (expt 2 31)))
351 (assert (eql (manyraw-bb copy
) 0.11))
352 (assert (eql (manyraw-cc copy
) 0.22d0
))
353 (assert (eql (manyraw-dd copy
) #c
(0.33
0.33)))
354 (assert (eql (manyraw-ee copy
) #c
(0.44d0
0.44d0
))))
356 ;;;; miscellaneous old bugs
358 (defstruct ya-struct
)
359 (when (ignore-errors (or (ya-struct-p) 12))
360 (error "YA-STRUCT-P of no arguments should signal an error."))
361 (when (ignore-errors (or (ya-struct-p 'too
'many
'arguments
) 12))
362 (error "YA-STRUCT-P of three arguments should signal an error."))
364 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
365 ;;; declared inside on the theory that slot types were already
366 ;;; checked, which bogusly suppressed unbound-variable and other
367 ;;; checks within the evaluation of initforms.
369 (defstruct (bug210a (:constructor bug210a
()))
373 ;;; Because of bug 210, this assertion used to fail.
374 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable
))
375 ;;; Even with bug 210, these assertions succeeded.
376 (assert (typep (nth-value 1 (ignore-errors *bug210
*)) 'unbound-variable
))
377 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable
))
379 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
380 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
381 ;;; setting up compiler-layout information would run before the
382 ;;; constructor function installing the layout was compiled. Make sure
383 ;;; that doesn't happen again.
384 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x
(y :not
)))
385 (assert (not (find-class 'foo-0-7-8-53 nil
)))
387 (assert (find-class 'foo-0-7-8-53 nil
))
388 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x
:s
)))
389 (assert (eq (foo-0-7-8-53-x foo-0-7-8-53
) :s
))
390 (assert (eq (foo-0-7-8-53-y foo-0-7-8-53
) :not
)))
393 (format t
"~&/returning success~%")
394 (quit :unix-status
104)