/[gcl]/gcl/ansi-tests/structure-00.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/structure-00.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by pfdietz, Sat Dec 14 04:54:00 2002 UTC revision 1.9 by pfdietz, Fri Dec 20 04:07:16 2002 UTC
# Line 106  Line 106 
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
# Line 174  do the defstruct." Line 177  do the defstruct."
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))
# Line 228  do the defstruct." Line 232  do the defstruct."
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)
# Line 273  do the defstruct." Line 282  do the defstruct."
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
# Line 296  do the defstruct." Line 305  do the defstruct."
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
# Line 325  do the defstruct." Line 334  do the defstruct."
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)
# Line 414  do the defstruct." Line 423  do the defstruct."
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))))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26