/[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.2 by pfdietz, Thu Oct 17 13:16:56 2002 UTC revision 1.3 by pfdietz, Tue Dec 10 05:00:16 2002 UTC
# Line 7  Line 7 
7  (declaim (optimize (safety 3)))  (declaim (optimize (safety 3)))
8    
9  (defun make-struct-test-name (structure-name n)  (defun make-struct-test-name (structure-name n)
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)))
13      (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
17              "-STRUCT-TEST-"              "/"
18              (princ-to-string n))              (princ-to-string n))))
           :cl-test))  
19    
20  (defun make-struct-p-fn (structure-name)  (defun make-struct-p-fn (structure-name)
21      (assert (typep structure-name '(or string symbol character)))
22    (setf structure-name (string structure-name))    (setf structure-name (string structure-name))
23    (intern (concatenate 'string    (intern (concatenate 'string
24              structure-name              structure-name
25              "-P")              "-P")))
           :cl-test))  
26    
27  (defun make-struct-copy-fn (structure-name)  (defun make-struct-copy-fn (structure-name)
28     (setf structure-name (string structure-name))    (assert (typep structure-name '(or string symbol character)))
29     (intern (concatenate 'string    (setf structure-name (string structure-name))
30               "COPY-"    (intern (concatenate 'string
31               structure-name)                         "COPY-"
32             :cl-test))                         structure-name)))
33    
34  (defun make-struct-field-fn (structure-name field-name)  (defun make-struct-field-fn (conc-name field-name)
35    "Make field accessor for a field in a structure"    "Make field accessor for a field in a structure"
36    (setf structure-name (string structure-name))    (assert (typep conc-name '(or string symbol character)))
37      (assert (typep field-name '(or string symbol character)))
38      (setf conc-name (string conc-name))
39    (setf field-name (string field-name))    (setf field-name (string field-name))
40    (intern (concatenate 'string    (intern (concatenate 'string conc-name field-name)))
             structure-name "-" field-name)  
           :cl-test))  
41    
42  (defun make-struct-make-fn (structure-name)  (defun make-struct-make-fn (structure-name)
43    "Make the make- function for a structure"    "Make the make- function for a structure"
44      (assert (typep structure-name '(or string symbol character)))
45    (setf structure-name (string structure-name))    (setf structure-name (string structure-name))
46    (intern (concatenate 'string    (intern (concatenate 'string
47              "MAKE-" structure-name)              "MAKE-" structure-name)))
           :cl-test))    
48    
49  (defun create-instance-of-type (type)  (defun create-instance-of-type (type)
50    "Return an instance of a type.  Signal an error if    "Return an instance of a type.  Signal an error if
# Line 94  Line 95 
95      (create-instance-of-type (second type)))      (create-instance-of-type (second type)))
96     (t (error "Cannot generate element for type ~S~%" type))))     (t (error "Cannot generate element for type ~S~%" type))))
97    
98    (defun find-option (option-list option &optional default)
99      (loop for opt in option-list
100            when (or (eq opt option)
101                     (and (consp opt)
102                          (eq (car opt) option)))
103            return opt
104            finally (return default)))
105    
106  ;;  ;;
107  ;; There are a number of standardized tests for  ;; There are a number of standardized tests for
108  ;; structures.  The following macro generates the  ;; structures.  The following macro generates the
# Line 104  Line 113 
113      (name-and-options &body slot-descriptions-and-documentation)      (name-and-options &body slot-descriptions-and-documentation)
114  "Construct standardized tests for a defstruct, and also  "Construct standardized tests for a defstruct, and also
115  do the defstruct."  do the defstruct."
116    (let* ((doc-string    (defstruct-with-tests-fun name-and-options
117           (when (and (consp slot-descriptions-and-documentation)      slot-descriptions-and-documentation))
118                      (stringp (car slot-descriptions-and-documentation)))  
119             (car slot-descriptions-and-documentation)))  (defun defstruct-with-tests-fun (name-and-options
120                                     slot-descriptions-and-documentation)
121      ;; Function called from macro defstruct-with-tests
122      (let* (
123             ;; Either NIL or the documentation string for the structure
124             (doc-string
125              (when (and (consp slot-descriptions-and-documentation)
126                         (stringp (car slot-descriptions-and-documentation)))
127                (car slot-descriptions-and-documentation)))
128    
129             ;; The list of slot descriptions that follows either the
130             ;; name and options or the doc string
131           (slot-descriptions           (slot-descriptions
132            (if doc-string (cdr slot-descriptions-and-documentation)            (if doc-string (cdr slot-descriptions-and-documentation)
133              slot-descriptions-and-documentation))              slot-descriptions-and-documentation))
134    
135             ;; The name of the structure (should be a symbol)
136           (name (if (consp name-and-options)           (name (if (consp name-and-options)
137                     (car name-and-options)                     (car name-and-options)
138                   name-and-options))                   name-and-options))
139             ;; The options list, or NIL if there were no options
140           (options (if (consp name-and-options)           (options (if (consp name-and-options)
141                        (cdr name-and-options)                        (cdr name-and-options)
142                      nil))                      nil))
143    
144             ;; List of symbols that are the names of the slots
145           (slot-names           (slot-names
146            (loop            (loop
147                for x in slot-descriptions collect                for x in slot-descriptions collect
148                  (if (consp x) (car x) x)))                  (if (consp x) (car x) x)))
149    
150             ;; Symbol obtained by prepending MAKE- to the name symbol
151           (make-fn (make-struct-make-fn name))           (make-fn (make-struct-make-fn name))
152           (p-fn (make-struct-p-fn name))  
153           (copy-fn (make-struct-copy-fn name))           ;; The :predicate option entry from OPTIONS, or NIL if none
154             (predicate-option (find-option options :predicate))
155    
156             ;; The name of the -P function, either the default or the
157             ;; one specified in the :predicate option
158             (p-fn (cond
159                    ((or (eq predicate-option :predicate)
160                         (null (cdr predicate-option)))
161                     (make-struct-p-fn name))
162                    ((cadr predicate-option) (cadr predicate-option))
163                    (t nil)))
164    
165             ;; The :copier option, or NIL if no such option specified
166             (copier-option (find-option options :copier))
167             ;; The name of the copier function, either the default or
168             ;; one speciefied in the :copier option
169             (copy-fn (cond
170                       ((or (eq copier-option :copier)
171                            (null (cdr copier-option)))
172                        (make-struct-copy-fn name))
173                       ((cadr copier-option) (cadr copier-option))
174                       (t nil)))
175    
176             ;; The :conc-name option, or NIL if none specified
177             (conc-option (find-option options :conc-name))
178             ;; String to be prepended to slot names to get the
179             ;; slot accessor function
180             (conc-prefix (cond
181                           ((null conc-option)
182                            (concatenate 'string (string name) "-"))
183                           ((or (eq conc-option :conc-name)
184                                (null (cadr conc-option)))
185                            "")
186                           (t (string (cadr conc-option)))))
187    
188           ;; a list of initial values           ;; a list of initial values
189           (initial-value-alist           (initial-value-alist
190            (loop            (loop
# Line 136  do the defstruct." Line 197  do the defstruct."
197                                        (cdr slot-desc)                                        (cdr slot-desc)
198                                      nil)))                                      nil)))
199                    (when (and (consp slot-attrs)                    (when (and (consp slot-attrs)
200                               (not (keywordp slot-attrs)))                               (not (keywordp (car slot-attrs))))
201                      (pop slot-attrs))                      (pop slot-attrs))
202                    (let ((type (getf slot-attrs :type)))                    (let ((type (getf slot-attrs :type)))
203                      (if type                      (if type
204                          (cons slot-name (create-instance-of-type type))                          (cons slot-name (create-instance-of-type type))
205                        (cons slot-name (gensym)))))))                        (cons slot-name (gensym)))))))
206           )           )
207        `(eval-when (compile load eval)      ;; Build the tests in an eval-when form
208           (defstruct ,name-and-options      `(eval-when (compile load eval)
209              ,@slot-descriptions-and-documentation)         (defstruct ,name-and-options
210                     ,@slot-descriptions-and-documentation)
211           ;; Test that structure is of the correct type  
212           (deftest ,(make-struct-test-name name 1)         ;; Test that structure is of the correct type
213               (not (not (typep (,make-fn) (quote ,name))))         (deftest ,(make-struct-test-name name 1)
214             t)           (and (functionp (function ,make-fn))
215                          (symbol-function (quote ,make-fn))
216           ;; Test that the -P predicate exists                (notnot (typep (,make-fn) (quote ,name))))
217           (deftest ,(make-struct-test-name name 2)           t)
218               (not (not (,p-fn (,make-fn))))  
219             t)         ;; Test that the predicate exists
220                   ,@(when p-fn
221           ;; Test that the elements of *universe* are not             `((deftest ,(make-struct-test-name name 2)
222           ;; of this type                 (and (functionp (function ,p-fn))
223           (deftest ,(make-struct-test-name name 3)                      (symbol-function (quote ,p-fn))
224               (count-if (function ,p-fn) *universe*)                      (notnot (,p-fn (,make-fn))))
225             0)                 t)))
226            
227           (deftest ,(make-struct-test-name name 4)         ;; Test that the elements of *universe* are not
228               (count-if (function (lambda (x) (typep x (quote ,name))))         ;; of this type
229                         *universe*)         (deftest ,(make-struct-test-name name 3)
230             0)           (count-if (function ,p-fn) *universe*)
231                     0)
232           ;; Check that the fields can be read after being initialized  
233           (deftest ,(make-struct-test-name name 5)         (deftest ,(make-struct-test-name name 4)
234               ,(let ((inits nil)           (count-if (function (lambda (x) (typep x (quote ,name))))
235                      (tests nil)                     *universe*)
236                      (var (gensym "X")))           0)
237                  (loop  
238                      for (slot-name . initval) in initial-value-alist         ;; Check that the fields can be read after being initialized
239                      do         (deftest ,(make-struct-test-name name 5)
240                        (setf inits           ,(let ((inits nil)
241                          (list* (intern (string slot-name) "KEYWORD")                  (tests nil)
242                                 (list 'quote initval)                  (var (gensym "X")))
243                                 inits))              (loop
244                        (push `(eql (quote ,initval)               for (slot-name . initval) in initial-value-alist
245                                    (,(make-struct-field-fn name slot-name)               do
246                                     ,var))               (setf inits
247                              tests))                     (list* (intern (string slot-name) "KEYWORD")
248                  `(let ((,var (,(make-struct-make-fn name) . ,inits)))                            (list 'quote initval)
249                     (and ,@tests t)))                            inits))
250             t)               (push `(eqlt (quote ,initval)
251                                      (,(make-struct-field-fn conc-prefix slot-name)
252           ;; Check that two invocations return different structures                             ,var))
253           (deftest ,(make-struct-test-name name 6)                     tests))
254               ,(let ((make-fn (make-struct-make-fn name)))              `(let ((,var (,make-fn . ,inits)))
255                  `(eqt (,make-fn) (,make-fn)))                 (and ,@tests t)))
256             nil)           t)
257            
258           ;; Check that we can setf the fields         ;; Check that two invocations return different structures
259           (deftest ,(make-struct-test-name name 7)         (deftest ,(make-struct-test-name name 6)
260               ,(let* ((var (gensym "X"))           (eqt (,make-fn) (,make-fn))
261                       (var2 (gensym "T"))           nil)
262                       (tests  
263                        (loop         ;; Check that we can setf the fields
264                            for (slot-name . initval) in initial-value-alist         (deftest ,(make-struct-test-name name 7)
265                            collect           ,(let* ((var (gensym "X"))
266                              (let ((field-fn (make-struct-field-fn name slot-name)))                   (var2 (gensym "T"))
267                                `(let ((,var2 (quote ,initval)))                   (tests
268                                   (setf (,field-fn ,var) ,var2)                    (loop
269                                   (eql (,field-fn ,var) ,var2))))))                     for (slot-name . initval) in initial-value-alist
270                  `(let ((,var (,(make-struct-make-fn name))))                     for slot-desc in slot-descriptions
271                     (and ,@tests t)))                     unless (and (consp slot-desc)
272             t)                                 (getf (cddr slot-desc) :read-only))
273                               collect
274           ;; Check that the copy function properly copies fields                     (let ((field-fn (make-struct-field-fn conc-prefix
275           (deftest ,(make-struct-test-name name 8)                                                           slot-name)))
276               ,(let* ((var (gensym "X"))                       `(let ((,var2 (quote ,initval)))
277                       (var2 (gensym "Y")))                          (setf (,field-fn ,var) ,var2)
278                  `(let ((,var (,(make-struct-make-fn name)                          (eqlt (,field-fn ,var) ,var2))))))
279                                ,@(loop              `(let ((,var (,make-fn)))
280                                      for (slot-name . initval) in initial-value-alist                 (and ,@tests t)))
281                                      nconc (list (intern (string slot-name) "KEYWORD")           t)
282                                                  `(quote ,initval))))))  
283                     (let ((,var2 (,(make-struct-copy-fn name) ,var)))         ;; Check that the copy function exists
284                       (and         ,@(when copy-fn
285                        (not (eql ,var ,var2))             `((deftest ,(make-struct-test-name name 8)
286                        ,@(loop                 (and (functionp (function ,copy-fn))
287                              for (slot-name . initval) in initial-value-alist                      (symbol-function (quote ,copy-fn))
288                              collect                      t)
289                                (let ((fn (make-struct-field-fn name slot-name)))                 t)))
290                                  `(eql (,fn ,var) (,fn ,var2))))  
291                        t))))         ;; Check that the copy function properly copies fields
292             t)         ,@(when copy-fn
293           )))             `((deftest ,(make-struct-test-name name 9)
294                   ,(let* ((var (gensym "X"))
295                           (var2 (gensym "Y")))
296                      `(let ((,var (,make-fn
297                                    ,@(loop
298                                       for (slot-name . initval)
299                                       in initial-value-alist
300                                       nconc (list (intern (string slot-name)
301                                                           "KEYWORD")
302                                                   `(quote ,initval))))))
303                         (let ((,var2 (,copy-fn ,var)))
304                           (and
305                            (not (eqlt ,var ,var2))
306                            ,@(loop
307                               for (slot-name . nil) in initial-value-alist
308                               collect
309                               (let ((fn (make-struct-field-fn conc-prefix
310                                                               slot-name)))
311                                 `(eqlt (,fn ,var) (,fn ,var2))))
312                            t))))
313                   t)))
314           )))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

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