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)
183 (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
185 (defstruct (,defstructname
186 ,@(when colontype `((:type ,colontype))))
187 ;; some ordinary tagged slots
189 (home nil :type package :read-only t)
190 (comment "" :type simple-string)
192 (weight 1.0 :type single-float)
193 (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
194 ;; more ordinary tagged slots
195 (refcount 0 :type (and unsigned-byte fixnum)))
197 (format t "~&/done with DEFSTRUCT~%")
199 (let* ((cn (string+ ',defstructname "-")) ; conc-name
200 (ctor (symbol-function (symbol+ "MAKE-" ',defstructname)))
201 (*instance* (funcall ctor
203 :home (find-package :cl)
204 :hash (+ 14 most-positive-fixnum)
207 ;; Check that ctor set up slot values correctly.
208 (format t "~&/checking constructed structure~%")
209 (assert (string= "some id" (read-slot cn "ID" *instance*)))
210 (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
211 (assert (string= "" (read-slot cn "COMMENT" *instance*)))
212 (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
213 (assert (eql (+ 14 most-positive-fixnum)
214 (read-slot cn "HASH" *instance*)))
215 (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
217 ;; There should be no writers for read-only slots.
218 (format t "~&/checking no read-only writers~%")
219 (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
220 (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
221 ;; (Read-only slot values are checked in the loop below.)
223 (dolist (inlinep '(t nil))
224 (format t "~&/doing INLINEP=~S~%" inlinep)
225 ;; Fiddle with writable slot values.
226 (let ((new-id (format nil "~S" (random 100)))
227 (new-comment (format nil "~X" (random 5555)))
228 (new-weight (random 10.0)))
229 (write-slot new-id cn "ID" *instance* inlinep)
230 (write-slot new-comment cn "COMMENT" *instance* inlinep)
231 (write-slot new-weight cn "WEIGHT" *instance* inlinep)
232 (assert (eql new-id (read-slot cn "ID" *instance*)))
233 (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
234 ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
235 ;; (error "WEIGHT mismatch: ~S vs. ~S"
236 ;; new-weight (read-slot cn "WEIGHT" *instance*)))
237 (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
238 (format t "~&/done with INLINEP loop~%")
240 ;; :TYPE FOO objects don't go in the Lisp type system, so we
241 ;; can't test TYPEP stuff for them.
243 ;; FIXME: However, when they're named, they do define
244 ;; predicate functions, and we could test those.
246 `(;; Fiddle with predicate function.
247 (let ((pred-name (symbol+ ',defstructname "-P")))
248 (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
249 (assert (funcall pred-name *instance*))
250 (assert (not (funcall pred-name 14)))
251 (assert (not (funcall pred-name "test")))
252 (assert (not (funcall pred-name (make-hash-table))))
254 (compile nil `(lambda (x) (,pred-name x)))))
255 (format t "~&/doing COMPILED-PRED tests~%")
256 (assert (funcall compiled-pred *instance*))
257 (assert (not (funcall compiled-pred 14)))
258 (assert (not (funcall compiled-pred #()))))
259 ;; Fiddle with TYPEP.
260 (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
261 (assert (typep *instance* ',defstructname))
262 (assert (not (typep 0 ',defstructname)))
263 (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
264 (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
265 (let* ((typename ',defstructname)
267 (compile nil `(lambda (x) (typep x ',typename)))))
268 (assert (funcall compiled-typep *instance*))
269 (assert (not (funcall compiled-typep nil))))))))
271 (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
273 (test-variant vanilla-struct)
274 (test-variant vector-struct :colontype vector)
275 (test-variant list-struct :colontype list)
277 ;;;; testing raw slots harder
279 ;;;; The offsets of raw slots need to be rescaled during the punning
280 ;;;; process which is used to access them. That seems like a good
281 ;;;; place for errors to lurk, so we'll try hunting for them by
282 ;;;; verifying that all the raw slot data gets written successfully
283 ;;;; into the object, can be copied with the object, and can then be
284 ;;;; read back out (with none of it ending up bogusly outside the
285 ;;;; object, so that it couldn't be copied, or bogusly overwriting
286 ;;;; some other raw slot).
289 (a (expt 2 30) :type (unsigned-byte 32))
290 (b 0.1 :type single-float)
291 (c 0.2d0 :type double-float)
292 (d #c(0.3 0.3) :type (complex single-float))
293 unraw-slot-just-for-variety
294 (e #c(0.4d0 0.4d0) :type (complex double-float))
295 (aa (expt 2 30) :type (unsigned-byte 32))
296 (bb 0.1 :type single-float)
297 (cc 0.2d0 :type double-float)
298 (dd #c(0.3 0.3) :type (complex single-float))
299 (ee #c(0.4d0 0.4d0) :type (complex double-float)))
301 (defvar *manyraw* (make-manyraw))
303 (assert (eql (manyraw-a *manyraw*) (expt 2 30)))
304 (assert (eql (manyraw-b *manyraw*) 0.1))
305 (assert (eql (manyraw-c *manyraw*) 0.2d0))
306 (assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
307 (assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
308 (assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
309 (assert (eql (manyraw-bb *manyraw*) 0.1))
310 (assert (eql (manyraw-cc *manyraw*) 0.2d0))
311 (assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
312 (assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
314 (setf (manyraw-aa *manyraw*) (expt 2 31)
315 (manyraw-bb *manyraw*) 0.11
316 (manyraw-cc *manyraw*) 0.22d0
317 (manyraw-dd *manyraw*) #c(0.33 0.33)
318 (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
320 (let ((copy (copy-manyraw *manyraw*)))
321 (assert (eql (manyraw-a copy) (expt 2 30)))
322 (assert (eql (manyraw-b copy) 0.1))
323 (assert (eql (manyraw-c copy) 0.2d0))
324 (assert (eql (manyraw-d copy) #c(0.3 0.3)))
325 (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0)))
326 (assert (eql (manyraw-aa copy) (expt 2 31)))
327 (assert (eql (manyraw-bb copy) 0.11))
328 (assert (eql (manyraw-cc copy) 0.22d0))
329 (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
330 (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
333 (format t "~&/returning success~%")
334 (quit :unix-status 104)