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 "assertoid.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
22 (assert (raises-error? (make-person) type-error))
23 (assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
27 (defstruct (astronaut (:include person)
30 (favorite-beverage 'tang))
31 (let ((x (make-astronaut :name "Buzz" :helmet-size 17.5)))
32 (assert (equal (person-name x) "Buzz"))
33 (assert (equal (astro-name x) "Buzz"))
34 (assert (eql (astro-favorite-beverage x) 'tang))
35 (assert (null (astro-age x))))
36 (defstruct (ancient-astronaut (:include person (age 77)))
38 (favorite-beverage 'tang))
39 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77))
41 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
42 (defstruct (binop (:type list) :named (:initial-offset 2))
43 (operator '? :type symbol)
46 (defstruct (annotated-binop (:type list)
49 commutative associative identity)
50 (assert (equal (make-annotated-binop :operator '*
56 '(nil nil binop * x 5 nil nil nil t t 1)))
58 ;;; effect of :NAMED on :TYPE
59 (defstruct (named-binop (:type list) :named)
60 (operator '? :type symbol)
63 (let ((named-binop (make-named-binop :operator '+ :operand-1 'x :operand-2 5)))
64 ;; The data representation is specified to look like this.
65 (assert (equal named-binop '(named-binop + x 5)))
66 ;; A meaningful NAMED-BINOP-P is defined.
67 (assert (named-binop-p named-binop))
68 (assert (named-binop-p (copy-list named-binop)))
69 (assert (not (named-binop-p (cons 11 named-binop))))
70 (assert (not (named-binop-p (find-package :cl)))))
76 (firetrucks 1 :type fixnum)
78 (elevation 5128 :read-only t))
79 (let ((town1 (make-town :area 0 :watertowers 0)))
80 (assert (town-p town1))
81 (assert (not (town-p 1)))
82 (assert (eql (town-area town1) 0))
83 (assert (eql (town-elevation town1) 5128))
84 (assert (null (town-population town1)))
85 (setf (town-population town1) 99)
86 (assert (eql (town-population town1) 99))
87 (let ((town2 (copy-town town1)))
88 (dolist (slot-accessor-name '(town-area
93 (assert (eql (funcall slot-accessor-name town1)
94 (funcall slot-accessor-name town2))))
95 (assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY
98 (defstruct (clown (:conc-name bozo-))
102 (let ((funny-clown (make-clown)))
103 (assert (eql (bozo-nose-color funny-clown) 'red)))
104 (defstruct (klown (:constructor make-up-klown)
105 (:copier clone-klown)
106 (:predicate is-a-bozo-p))
110 (assert (is-a-bozo-p (make-up-klown)))
112 ;;;; systematically testing variants of DEFSTRUCT:
113 ;;;; * native, :TYPE LIST, and :TYPE VECTOR
115 ;;; FIXME: things to test:
116 ;;; * Slot readers work.
117 ;;; * Slot writers work.
118 ;;; * Predicates work.
120 ;;; FIXME: things that would be nice to test systematically someday:
121 ;;; * constructors (default, boa..)
123 ;;; * no type checks when (> SPEED SAFETY)
124 ;;; * Tests of inclusion would be good. (It's tested very lightly
125 ;;; above, and then tested a fair amount by the system compiling
128 (defun string+ (&rest rest)
129 (apply #'concatenate 'string
130 (mapcar #'string rest)))
131 (defun symbol+ (&rest rest)
132 (values (intern (apply #'string+ rest))))
134 (defun accessor-name (conc-name slot-name)
135 (symbol+ conc-name slot-name))
137 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
138 ;;; to read and write a structure slot.
139 (defun read-slot-notinline (conc-name slot-name instance)
140 (funcall (accessor-name conc-name slot-name) instance))
141 (defun write-slot-notinline (new-value conc-name slot-name instance)
142 (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
145 ;;; Use inline expansions of slot accessors, if possible, to read and
146 ;;; write a structure slot.
147 (defun read-slot-inline (conc-name slot-name instance)
148 (funcall (compile nil
150 (,(accessor-name conc-name slot-name) instance)))
152 (defun write-slot-inline (new-value conc-name slot-name instance)
153 (funcall (compile nil
154 `(lambda (new-value instance)
155 (setf (,(accessor-name conc-name slot-name) instance)
160 ;;; Read a structure slot, checking that the inline and out-of-line
161 ;;; accessors give the same result.
162 (defun read-slot (conc-name slot-name instance)
163 (let ((inline-value (read-slot-inline conc-name slot-name instance))
164 (notinline-value (read-slot-notinline conc-name slot-name instance)))
165 (assert (eql inline-value notinline-value))
168 ;;; Write a structure slot, using INLINEP argument to decide
169 ;;; on inlineness of accessor used.
170 (defun write-slot (new-value conc-name slot-name instance inlinep)
172 (write-slot-inline new-value conc-name slot-name instance)
173 (write-slot-notinline new-value conc-name slot-name instance)))
175 ;;; bound during the tests so that we can get to it even if the
176 ;;; debugger is having a bad day
179 (defmacro test-variant (defstructname &key colontype boa-constructor-p)
182 (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
184 (defstruct (,defstructname
185 ,@(when colontype `((:type ,colontype)))
186 ,@(when boa-constructor-p
187 `((:constructor ,(symbol+ "CREATE-" defstructname)
190 (optional-test 2 optional-test-p)
193 (no-home-comment "Home package CL not provided.")
194 (comment (if home-p "" no-home-comment))
195 (refcount (if optional-test-p optional-test nil))
199 ;; some ordinary tagged slots
201 (home nil :type package :read-only t)
202 (comment "" :type simple-string)
204 (weight 1.0 :type single-float)
205 (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
206 ;; more ordinary tagged slots
207 (refcount 0 :type (and unsigned-byte fixnum)))
209 (format t "~&/done with DEFSTRUCT~%")
211 (let* ((cn (string+ ',defstructname "-")) ; conc-name
212 (ctor (symbol-function ',(symbol+ (if boa-constructor-p
216 (*instance* (funcall ctor
217 ,@(unless boa-constructor-p
219 ,@(when boa-constructor-p
221 :home (find-package :cl)
222 :hash (+ 14 most-positive-fixnum)
223 ,@(unless boa-constructor-p
226 ;; Check that ctor set up slot values correctly.
227 (format t "~&/checking constructed structure~%")
228 (assert (string= "some id" (read-slot cn "ID" *instance*)))
229 (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
230 (assert (string= "" (read-slot cn "COMMENT" *instance*)))
231 (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
232 (assert (eql (+ 14 most-positive-fixnum)
233 (read-slot cn "HASH" *instance*)))
234 (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
236 ;; There should be no writers for read-only slots.
237 (format t "~&/checking no read-only writers~%")
238 (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
239 (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
240 ;; (Read-only slot values are checked in the loop below.)
242 (dolist (inlinep '(t nil))
243 (format t "~&/doing INLINEP=~S~%" inlinep)
244 ;; Fiddle with writable slot values.
245 (let ((new-id (format nil "~S" (random 100)))
246 (new-comment (format nil "~X" (random 5555)))
247 (new-weight (random 10.0)))
248 (write-slot new-id cn "ID" *instance* inlinep)
249 (write-slot new-comment cn "COMMENT" *instance* inlinep)
250 (write-slot new-weight cn "WEIGHT" *instance* inlinep)
251 (assert (eql new-id (read-slot cn "ID" *instance*)))
252 (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
253 ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
254 ;; (error "WEIGHT mismatch: ~S vs. ~S"
255 ;; new-weight (read-slot cn "WEIGHT" *instance*)))
256 (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
257 (format t "~&/done with INLINEP loop~%")
259 ;; :TYPE FOO objects don't go in the Lisp type system, so we
260 ;; can't test TYPEP stuff for them.
262 ;; FIXME: However, when they're named, they do define
263 ;; predicate functions, and we could test those.
265 `(;; Fiddle with predicate function.
266 (let ((pred-name (symbol+ ',defstructname "-P")))
267 (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
268 (assert (funcall pred-name *instance*))
269 (assert (not (funcall pred-name 14)))
270 (assert (not (funcall pred-name "test")))
271 (assert (not (funcall pred-name (make-hash-table))))
273 (compile nil `(lambda (x) (,pred-name x)))))
274 (format t "~&/doing COMPILED-PRED tests~%")
275 (assert (funcall compiled-pred *instance*))
276 (assert (not (funcall compiled-pred 14)))
277 (assert (not (funcall compiled-pred #()))))
278 ;; Fiddle with TYPEP.
279 (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
280 (assert (typep *instance* ',defstructname))
281 (assert (not (typep 0 ',defstructname)))
282 (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
283 (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
284 (let* ((typename ',defstructname)
286 (compile nil `(lambda (x) (typep x ',typename)))))
287 (assert (funcall compiled-typep *instance*))
288 (assert (not (funcall compiled-typep nil))))))))
290 (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
292 (test-variant vanilla-struct)
293 (test-variant vector-struct :colontype vector)
294 (test-variant list-struct :colontype list)
295 (test-variant vanilla-struct :boa-constructor-p t)
296 (test-variant vector-struct :colontype vector :boa-constructor-p t)
297 (test-variant list-struct :colontype list :boa-constructor-p t)
300 ;;;; testing raw slots harder
302 ;;;; The offsets of raw slots need to be rescaled during the punning
303 ;;;; process which is used to access them. That seems like a good
304 ;;;; place for errors to lurk, so we'll try hunting for them by
305 ;;;; verifying that all the raw slot data gets written successfully
306 ;;;; into the object, can be copied with the object, and can then be
307 ;;;; read back out (with none of it ending up bogusly outside the
308 ;;;; object, so that it couldn't be copied, or bogusly overwriting
309 ;;;; some other raw slot).
312 (a (expt 2 30) :type (unsigned-byte 32))
313 (b 0.1 :type single-float)
314 (c 0.2d0 :type double-float)
315 (d #c(0.3 0.3) :type (complex single-float))
316 unraw-slot-just-for-variety
317 (e #c(0.4d0 0.4d0) :type (complex double-float))
318 (aa (expt 2 30) :type (unsigned-byte 32))
319 (bb 0.1 :type single-float)
320 (cc 0.2d0 :type double-float)
321 (dd #c(0.3 0.3) :type (complex single-float))
322 (ee #c(0.4d0 0.4d0) :type (complex double-float)))
324 (defvar *manyraw* (make-manyraw))
326 (assert (eql (manyraw-a *manyraw*) (expt 2 30)))
327 (assert (eql (manyraw-b *manyraw*) 0.1))
328 (assert (eql (manyraw-c *manyraw*) 0.2d0))
329 (assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
330 (assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
331 (assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
332 (assert (eql (manyraw-bb *manyraw*) 0.1))
333 (assert (eql (manyraw-cc *manyraw*) 0.2d0))
334 (assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
335 (assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
337 (setf (manyraw-aa *manyraw*) (expt 2 31)
338 (manyraw-bb *manyraw*) 0.11
339 (manyraw-cc *manyraw*) 0.22d0
340 (manyraw-dd *manyraw*) #c(0.33 0.33)
341 (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
343 (let ((copy (copy-manyraw *manyraw*)))
344 (assert (eql (manyraw-a copy) (expt 2 30)))
345 (assert (eql (manyraw-b copy) 0.1))
346 (assert (eql (manyraw-c copy) 0.2d0))
347 (assert (eql (manyraw-d copy) #c(0.3 0.3)))
348 (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0)))
349 (assert (eql (manyraw-aa copy) (expt 2 31)))
350 (assert (eql (manyraw-bb copy) 0.11))
351 (assert (eql (manyraw-cc copy) 0.22d0))
352 (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
353 (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
355 ;;;; miscellaneous old bugs
357 (defstruct ya-struct)
358 (when (ignore-errors (or (ya-struct-p) 12))
359 (error "YA-STRUCT-P of no arguments should signal an error."))
360 (when (ignore-errors (or (ya-struct-p 'too 'many 'arguments) 12))
361 (error "YA-STRUCT-P of three arguments should signal an error."))
363 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
364 ;;; declared inside on the theory that slot types were already
365 ;;; checked, which bogusly suppressed unbound-variable and other
366 ;;; checks within the evaluation of initforms.
368 (defstruct (bug210a (:constructor bug210a ()))
372 ;;; Because of bug 210, this assertion used to fail.
373 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable))
374 ;;; Even with bug 210, these assertions succeeded.
375 (assert (typep (nth-value 1 (ignore-errors *bug210*)) 'unbound-variable))
376 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable))
378 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
379 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
380 ;;; setting up compiler-layout information would run before the
381 ;;; constructor function installing the layout was compiled. Make sure
382 ;;; that doesn't happen again.
383 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x (y :not)))
384 (assert (not (find-class 'foo-0-7-8-53 nil)))
386 (assert (find-class 'foo-0-7-8-53 nil))
387 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x :s)))
388 (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
389 (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))
391 ;;; tests of behaviour of colliding accessors.
392 (defstruct (bug127-foo (:conc-name bug127-baz-)) a)
393 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
394 (defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
395 (assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
396 (assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
397 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
399 (defun bug127-flurble (x)
401 (defstruct bug127 flurble)
402 (assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
404 (defstruct bug127-a b-c)
405 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
406 (defstruct (bug127-a-b (:include bug127-a)) c)
407 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
408 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
410 (defstruct (bug127-e (:conc-name bug127--)) foo)
411 (assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
412 (defstruct (bug127-f (:conc-name bug127--)) foo)
413 (assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
414 (assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error))
416 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
418 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
420 (defstruct (conc-name-syntax :conc-name) a-conc-name-slot)
421 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y))
423 ;;; and further :CONC-NAME NIL was being wrongly treated:
424 (defpackage "DEFSTRUCT-TEST-SCRATCH")
425 (defstruct (conc-name-nil :conc-name)
426 defstruct-test-scratch::conc-name-nil-slot)
427 (assert (= (defstruct-test-scratch::conc-name-nil-slot
428 (make-conc-name-nil :conc-name-nil-slot 1)) 1))
429 (assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
433 (format t "~&/returning success~%")
434 (quit :unix-status 104)