Commit ad6c20d0 authored by pfdietz's avatar pfdietz
Browse files

Modified structure tests to use interned temporary names. Added beginning of...

Modified structure tests to use interned temporary names.  Added beginning of :include option handling.
parent c6fa246e
...@@ -106,6 +106,9 @@ ...@@ -106,6 +106,9 @@
return opt return opt
finally (return default))) finally (return default)))
(defvar *defstruct-with-tests-names* nil
"Names of structure types defined with DEFSRUCT-WITH-TESTS.")
;; ;;
;; There are a number of standardized tests for ;; There are a number of standardized tests for
;; structures. The following macro generates the ;; structures. The following macro generates the
...@@ -174,6 +177,7 @@ do the defstruct." ...@@ -174,6 +177,7 @@ do the defstruct."
(struct-type (second type-option)) (struct-type (second type-option))
(named-option (find-option options :named)) (named-option (find-option options :named))
(include-option (find-option options :include))
;; The :predicate option entry from OPTIONS, or NIL if none ;; The :predicate option entry from OPTIONS, or NIL if none
(predicate-option (find-option options :predicate)) (predicate-option (find-option options :predicate))
...@@ -228,15 +232,20 @@ do the defstruct." ...@@ -228,15 +232,20 @@ do the defstruct."
for slot-desc in slot-descriptions for slot-desc in slot-descriptions
for slot-name in slot-names for slot-name in slot-names
for type in slot-types for type in slot-types
for i from 1
collect (if (not (eq type :none)) collect (if (not (eq type :none))
(cons slot-name (create-instance-of-type type)) (cons slot-name (create-instance-of-type type))
(cons slot-name (gensym))))) (cons slot-name (defstruct-maketemp name "SLOTTEMP" i)))))
) )
;; Build the tests in an eval-when form ;; Build the tests in an eval-when form
`(eval-when (compile load eval) `(eval-when (compile load eval)
(ignore-errors (ignore-errors
(eval '(defstruct ,name-and-options (eval '(defstruct ,name-and-options
,@slot-descriptions-and-documentation))) ,@slot-descriptions-and-documentation))
,(unless (or type-option include-option)
`(pushnew ',name *defstruct-with-tests-names*))
nil)
;; Test that structure is of the correct type ;; Test that structure is of the correct type
(deftest ,(make-struct-test-name name 1) (deftest ,(make-struct-test-name name 1)
...@@ -273,7 +282,7 @@ do the defstruct." ...@@ -273,7 +282,7 @@ do the defstruct."
(deftest ,(make-struct-test-name name 5) (deftest ,(make-struct-test-name name 5)
,(let ((inits nil) ,(let ((inits nil)
(tests nil) (tests nil)
(var (gensym "X"))) (var (defstruct-maketemp name "TEMP-5")))
(loop (loop
for (slot-name . initval) in initial-value-alist for (slot-name . initval) in initial-value-alist
for field-fn in field-fns for field-fn in field-fns
...@@ -296,8 +305,8 @@ do the defstruct." ...@@ -296,8 +305,8 @@ do the defstruct."
;; Check that we can setf the fields ;; Check that we can setf the fields
(deftest ,(make-struct-test-name name 7) (deftest ,(make-struct-test-name name 7)
,(let* ((var (gensym "X")) ,(let* ((var (defstruct-maketemp name "TEMP-7-1"))
(var2 (gensym "T")) (var2 (defstruct-maketemp name "TEMP-7-2"))
(tests (tests
(loop (loop
for (slot-name . initval) in initial-value-alist for (slot-name . initval) in initial-value-alist
...@@ -325,8 +334,8 @@ do the defstruct." ...@@ -325,8 +334,8 @@ do the defstruct."
;; Check that the copy function properly copies fields ;; Check that the copy function properly copies fields
,@(when copy-fn ,@(when copy-fn
`((deftest ,(make-struct-test-name name 9) `((deftest ,(make-struct-test-name name 9)
,(let* ((var (gensym "X")) ,(let* ((var 'XTEMP-9)
(var2 (gensym "Y"))) (var2 'YTEMP-9))
`(let ((,var (,make-fn `(let ((,var (,make-fn
,@(loop ,@(loop
for (slot-name . initval) for (slot-name . initval)
...@@ -414,6 +423,11 @@ do the defstruct." ...@@ -414,6 +423,11 @@ do the defstruct."
collect type)) collect type))
nil) nil)
)) ))
nil nil
))) )))
(defun defstruct-maketemp (stem suffix1 &optional suffix2)
"Make a temporary variable for DEFSTRUCT-WITH-TESTS."
(intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2)
(format nil "~A-~A" stem suffix1))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment