106 |
return opt |
return opt |
107 |
finally (return default))) |
finally (return default))) |
108 |
|
|
109 |
|
(defvar *defstruct-with-tests-names* nil |
110 |
|
"Names of structure types defined with DEFSRUCT-WITH-TESTS.") |
111 |
|
|
112 |
;; |
;; |
113 |
;; There are a number of standardized tests for |
;; There are a number of standardized tests for |
114 |
;; structures. The following macro generates the |
;; structures. The following macro generates the |
177 |
(struct-type (second type-option)) |
(struct-type (second type-option)) |
178 |
|
|
179 |
(named-option (find-option options :named)) |
(named-option (find-option options :named)) |
180 |
|
(include-option (find-option options :include)) |
181 |
|
|
182 |
;; The :predicate option entry from OPTIONS, or NIL if none |
;; The :predicate option entry from OPTIONS, or NIL if none |
183 |
(predicate-option (find-option options :predicate)) |
(predicate-option (find-option options :predicate)) |
232 |
for slot-desc in slot-descriptions |
for slot-desc in slot-descriptions |
233 |
for slot-name in slot-names |
for slot-name in slot-names |
234 |
for type in slot-types |
for type in slot-types |
235 |
|
for i from 1 |
236 |
collect (if (not (eq type :none)) |
collect (if (not (eq type :none)) |
237 |
(cons slot-name (create-instance-of-type type)) |
(cons slot-name (create-instance-of-type type)) |
238 |
(cons slot-name (gensym))))) |
(cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) |
239 |
) |
) |
240 |
;; Build the tests in an eval-when form |
;; Build the tests in an eval-when form |
241 |
`(eval-when (compile load eval) |
`(eval-when (compile load eval) |
242 |
|
|
243 |
(ignore-errors |
(ignore-errors |
244 |
(eval '(defstruct ,name-and-options |
(eval '(defstruct ,name-and-options |
245 |
,@slot-descriptions-and-documentation))) |
,@slot-descriptions-and-documentation)) |
246 |
|
,(unless (or type-option include-option) |
247 |
|
`(pushnew ',name *defstruct-with-tests-names*)) |
248 |
|
nil) |
249 |
|
|
250 |
;; Test that structure is of the correct type |
;; Test that structure is of the correct type |
251 |
(deftest ,(make-struct-test-name name 1) |
(deftest ,(make-struct-test-name name 1) |
282 |
(deftest ,(make-struct-test-name name 5) |
(deftest ,(make-struct-test-name name 5) |
283 |
,(let ((inits nil) |
,(let ((inits nil) |
284 |
(tests nil) |
(tests nil) |
285 |
(var (gensym "X"))) |
(var (defstruct-maketemp name "TEMP-5"))) |
286 |
(loop |
(loop |
287 |
for (slot-name . initval) in initial-value-alist |
for (slot-name . initval) in initial-value-alist |
288 |
for field-fn in field-fns |
for field-fn in field-fns |
305 |
|
|
306 |
;; Check that we can setf the fields |
;; Check that we can setf the fields |
307 |
(deftest ,(make-struct-test-name name 7) |
(deftest ,(make-struct-test-name name 7) |
308 |
,(let* ((var (gensym "X")) |
,(let* ((var (defstruct-maketemp name "TEMP-7-1")) |
309 |
(var2 (gensym "T")) |
(var2 (defstruct-maketemp name "TEMP-7-2")) |
310 |
(tests |
(tests |
311 |
(loop |
(loop |
312 |
for (slot-name . initval) in initial-value-alist |
for (slot-name . initval) in initial-value-alist |
334 |
;; Check that the copy function properly copies fields |
;; Check that the copy function properly copies fields |
335 |
,@(when copy-fn |
,@(when copy-fn |
336 |
`((deftest ,(make-struct-test-name name 9) |
`((deftest ,(make-struct-test-name name 9) |
337 |
,(let* ((var (gensym "X")) |
,(let* ((var 'XTEMP-9) |
338 |
(var2 (gensym "Y"))) |
(var2 'YTEMP-9)) |
339 |
`(let ((,var (,make-fn |
`(let ((,var (,make-fn |
340 |
,@(loop |
,@(loop |
341 |
for (slot-name . initval) |
for (slot-name . initval) |
423 |
collect type)) |
collect type)) |
424 |
nil) |
nil) |
425 |
)) |
)) |
426 |
|
|
427 |
nil |
nil |
428 |
))) |
))) |
429 |
|
|
430 |
|
(defun defstruct-maketemp (stem suffix1 &optional suffix2) |
431 |
|
"Make a temporary variable for DEFSTRUCT-WITH-TESTS." |
432 |
|
(intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2) |
433 |
|
(format nil "~A-~A" stem suffix1)))) |