10 |
;; (declare (type (or string symbol character) structure-name) |
;; (declare (type (or string symbol character) structure-name) |
11 |
;; (type fixnum n)) |
;; (type fixnum n)) |
12 |
(assert (typep structure-name '(or string symbol character))) |
(assert (typep structure-name '(or string symbol character))) |
13 |
(assert (typep n 'fixnum)) |
;; (assert (typep n 'fixnum)) |
14 |
(setf structure-name (string structure-name)) |
(setf structure-name (string structure-name)) |
15 |
(intern (concatenate 'string |
(intern (concatenate 'string |
16 |
structure-name |
structure-name |
285 |
;; Test that the predicate exists |
;; Test that the predicate exists |
286 |
,@(when p-fn |
,@(when p-fn |
287 |
`((deftest ,(make-struct-test-name name 2) |
`((deftest ,(make-struct-test-name name 2) |
288 |
(and (fboundp (quote ,p-fn)) |
(let ((s (,make-fn))) |
289 |
(functionp (function ,p-fn)) |
(and (fboundp (quote ,p-fn)) |
290 |
(symbol-function (quote ,p-fn)) |
(functionp (function ,p-fn)) |
291 |
(notnot (funcall #',p-fn (,make-fn))) |
(symbol-function (quote ,p-fn)) |
292 |
(notnot (,p-fn (,make-fn)))) |
(notnot (funcall #',p-fn s)) |
293 |
t))) |
(notnot (,p-fn s)) |
294 |
|
)) |
295 |
|
t) |
296 |
|
(deftest ,(make-struct-test-name name "ERROR.1") |
297 |
|
(classify-error (,p-fn)) |
298 |
|
program-error) |
299 |
|
(deftest ,(make-struct-test-name name "ERROR.2") |
300 |
|
(classify-error (,p-fn (,make-fn) nil)) |
301 |
|
program-error) |
302 |
|
)) |
303 |
|
|
304 |
;; Test that the elements of *universe* are not |
;; Test that the elements of *universe* are not |
305 |
;; of this type |
;; of this type |
326 |
(list* (intern (string slot-name) "KEYWORD") |
(list* (intern (string slot-name) "KEYWORD") |
327 |
(list 'quote initval) |
(list 'quote initval) |
328 |
inits)) |
inits)) |
329 |
(push `(and (eqlt (quote ,initval) |
(push `(and |
330 |
(,field-fn ,var)) |
(eqlt (quote ,initval) |
331 |
(eqlt (quote ,initval) |
(,field-fn ,var)) |
332 |
(funcall #',field-fn ,var))) |
(eqlt (quote ,initval) |
333 |
|
(funcall #',field-fn ,var))) |
334 |
tests)) |
tests)) |
335 |
`(let ((,var (,make-fn . ,inits))) |
`(let ((,var (,make-fn . ,inits))) |
336 |
(and ,@tests t))) |
(and ,@tests t))) |
337 |
t) |
t) |
338 |
|
|
339 |
|
(deftest ,(make-struct-test-name name "ERROR.3") |
340 |
|
(remove nil |
341 |
|
(list |
342 |
|
,@(loop |
343 |
|
for (slot-name . initval) in initial-value-alist |
344 |
|
for field-fn in field-fns |
345 |
|
collect |
346 |
|
`(let ((x (classify-error (,field-fn)))) |
347 |
|
(unless (eqt x 'program-error) |
348 |
|
(list ',slot-name ',field-fn x)))))) |
349 |
|
nil) |
350 |
|
|
351 |
|
(deftest ,(make-struct-test-name name "ERROR.4") |
352 |
|
(remove nil |
353 |
|
(list |
354 |
|
,@(loop |
355 |
|
for (slot-name . initval) in initial-value-alist |
356 |
|
for field-fn in field-fns |
357 |
|
collect |
358 |
|
`(let ((x (classify-error (,field-fn (,make-fn) nil)))) |
359 |
|
(unless (eqt x 'program-error) |
360 |
|
(list ',slot-name ',field-fn x)))))) |
361 |
|
nil) |
362 |
|
|
363 |
;; Check that two invocations return different structures |
;; Check that two invocations return different structures |
364 |
(deftest ,(make-struct-test-name name 6) |
(deftest ,(make-struct-test-name name 6) |
365 |
(eqt (,make-fn) (,make-fn)) |
(eqt (,make-fn) (,make-fn)) |
391 |
(functionp (function ,copy-fn)) |
(functionp (function ,copy-fn)) |
392 |
(symbol-function (quote ,copy-fn)) |
(symbol-function (quote ,copy-fn)) |
393 |
t) |
t) |
394 |
t))) |
t) |
395 |
|
(deftest ,(make-struct-test-name name "ERROR.5") |
396 |
|
(classify-error (,copy-fn)) |
397 |
|
program-error) |
398 |
|
(deftest ,(make-struct-test-name name "ERROR.6") |
399 |
|
(classify-error (,copy-fn (,make-fn) nil)) |
400 |
|
program-error) |
401 |
|
)) |
402 |
|
|
403 |
;; Check that the copy function properly copies fields |
;; Check that the copy function properly copies fields |
404 |
,@(when copy-fn |
,@(when copy-fn |