/[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.4 by pfdietz, Wed Dec 11 13:35:16 2002 UTC revision 1.5 by pfdietz, Thu Dec 12 03:41:09 2002 UTC
# Line 144  do the defstruct." Line 144  do the defstruct."
144           ;; List of symbols that are the names of the slots           ;; 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             ;; List of slot types, if any
151             (slot-types
152              (loop
153               for x in slot-descriptions collect
154               (if (consp x)
155                   (getf (cddr x) :type :none)
156                 :none)))
157    
158             ;; read-only flags for slots
159             (slot-read-only
160              (loop
161               for x in slot-descriptions collect
162               (and (consp x)
163                    (getf (cddr x) :read-only))))
164    
165           ;; Symbol obtained by prepending MAKE- to the name symbol           ;; Symbol obtained by prepending MAKE- to the name symbol
166           (make-fn (make-struct-make-fn name))           (make-fn (make-struct-make-fn name))
# Line 189  do the defstruct." Line 204  do the defstruct."
204                          "")                          "")
205                         (t (string (cadr conc-option)))))                         (t (string (cadr conc-option)))))
206    
207             ;; Accessor names
208             (field-fns
209              (loop for slot-name in slot-names
210                    collect (make-struct-field-fn conc-prefix slot-name)))
211    
212           ;; a list of initial values           ;; a list of initial values
213           (initial-value-alist           (initial-value-alist
214            (loop            (loop
215                for slot-desc in slot-descriptions             for slot-desc in slot-descriptions
216                collect             for slot-name in slot-names
217                  (let ((slot-name (if (consp slot-desc)             for type      in slot-types
218                                       (car slot-desc)             collect (if (not (eq type :none))
219                                     slot-desc))                         (cons slot-name (create-instance-of-type type))
220                        (slot-attrs (if (consp slot-desc)                       (cons slot-name (gensym)))))
                                       (cdr slot-desc)  
                                     nil)))  
                   (when (and (consp slot-attrs)  
                              (not (keywordp (car slot-attrs))))  
                     (pop slot-attrs))  
                   (let ((type (getf slot-attrs :type)))  
                     (if type  
                         (cons slot-name (create-instance-of-type type))  
                       (cons slot-name (gensym)))))))  
221           )           )
222      ;; Build the tests in an eval-when form      ;; Build the tests in an eval-when form
223      `(eval-when (compile load eval)      `(eval-when (compile load eval)
224         (defstruct ,name-and-options         (ignore-errors
225           ,@slot-descriptions-and-documentation)           (eval '(defstruct ,name-and-options
226                      ,@slot-descriptions-and-documentation)))
227    
228         ;; Test that structure is of the correct type         ;; Test that structure is of the correct type
229         (deftest ,(make-struct-test-name name 1)         (deftest ,(make-struct-test-name name 1)
# Line 230  do the defstruct." Line 242  do the defstruct."
242                      (notnot (,p-fn (,make-fn))))                      (notnot (,p-fn (,make-fn))))
243                 t)))                 t)))
244    
        ;; When the predicate is not the default, check  
        ;; that the default is not defined.  Tests should  
        ;; be designed so that this function name doesn't  
        ;; collide with anything else.  
        ,@(unless (eq p-fn p-fn-default)  
            `((deftest ,(make-struct-test-name name 10)  
                (fboundp (quote ,p-fn-default))  
                nil)))  
   
245         ;; Test that the elements of *universe* are not         ;; Test that the elements of *universe* are not
246         ;; of this type         ;; of this type
247         ,@(when p-fn         ,@(when p-fn
# Line 258  do the defstruct." Line 261  do the defstruct."
261                  (var (gensym "X")))                  (var (gensym "X")))
262              (loop              (loop
263               for (slot-name . initval) in initial-value-alist               for (slot-name . initval) in initial-value-alist
264                 for field-fn in field-fns
265               do               do
266               (setf inits               (setf inits
267                     (list* (intern (string slot-name) "KEYWORD")                     (list* (intern (string slot-name) "KEYWORD")
268                            (list 'quote initval)                            (list 'quote initval)
269                            inits))                            inits))
270               (push `(eqlt (quote ,initval)               (push `(eqlt (quote ,initval)
271                            (,(make-struct-field-fn conc-prefix slot-name)                            (,field-fn ,var))
                            ,var))  
272                     tests))                     tests))
273              `(let ((,var (,make-fn . ,inits)))              `(let ((,var (,make-fn . ,inits)))
274                 (and ,@tests t)))                 (and ,@tests t)))
# Line 283  do the defstruct." Line 286  do the defstruct."
286                   (tests                   (tests
287                    (loop                    (loop
288                     for (slot-name . initval) in initial-value-alist                     for (slot-name . initval) in initial-value-alist
289                       for read-only-p in slot-read-only
290                     for slot-desc in slot-descriptions                     for slot-desc in slot-descriptions
291                     unless (and (consp slot-desc)                     for field-fn in field-fns
292                                 (getf (cddr slot-desc) :read-only))                     unless read-only-p
293                     collect                     collect
294                     (let ((field-fn (make-struct-field-fn conc-prefix                     `(let ((,var2 (quote ,initval)))
295                                                           slot-name)))                        (setf (,field-fn ,var) ,var2)
296                       `(let ((,var2 (quote ,initval)))                        (eqlt (,field-fn ,var) ,var2)))))
                         (setf (,field-fn ,var) ,var2)  
                         (eqlt (,field-fn ,var) ,var2))))))  
297              `(let ((,var (,make-fn)))              `(let ((,var (,make-fn)))
298                 (and ,@tests t)))                 (and ,@tests t)))
299           t)           t)
# Line 305  do the defstruct." Line 307  do the defstruct."
307                      t)                      t)
308                 t)))                 t)))
309    
        ;; When the copy function name is not the default, check  
        ;; that the default function is not defined.  Tests should  
        ;; be designed so that this name is not accidently defined  
        ;; for something else.  
        ,@(unless (eq copy-fn copy-fn-default)  
            `((deftest ,(make-struct-test-name name 11)  
                (fboundp (quote ,copy-fn-default))  
                nil)))  
   
310         ;; Check that the copy function properly copies fields         ;; Check that the copy function properly copies fields
311         ,@(when copy-fn         ,@(when copy-fn
312             `((deftest ,(make-struct-test-name name 9)             `((deftest ,(make-struct-test-name name 9)
# Line 331  do the defstruct." Line 324  do the defstruct."
324                          (not (eqlt ,var ,var2))                          (not (eqlt ,var ,var2))
325                          ,@(loop                          ,@(loop
326                             for (slot-name . nil) in initial-value-alist                             for (slot-name . nil) in initial-value-alist
327                               for fn in field-fns
328                             collect                             collect
329                             (let ((fn (make-struct-field-fn conc-prefix                             `(eqlt (,fn ,var) (,fn ,var2)))
                                                            slot-name)))  
                              `(eqlt (,fn ,var) (,fn ,var2))))  
330                          t))))                          t))))
331                 t)))                 t)))
332    
333           ;; When the predicate is not the default, check
334           ;; that the default is not defined.  Tests should
335           ;; be designed so that this function name doesn't
336           ;; collide with anything else.
337           ,@(unless (eq p-fn p-fn-default)
338               `((deftest ,(make-struct-test-name name 10)
339                   (fboundp (quote ,p-fn-default))
340                   nil)))
341    
342           ;; When the copy function name is not the default, check
343           ;; that the default function is not defined.  Tests should
344           ;; be designed so that this name is not accidently defined
345           ;; for something else.
346           ,@(unless (eq copy-fn copy-fn-default)
347               `((deftest ,(make-struct-test-name name 11)
348                   (fboundp (quote ,copy-fn-default))
349                   nil)))
350    
351           ;; When there are read-only slots, test that the SETF
352           ;; form for them is not FBOUNDP
353           ,@(when (loop for x in slot-read-only thereis x)
354               `((deftest ,(make-struct-test-name name 12)
355                   (and
356                    ,@(loop for slot-name in slot-names
357                            for read-only in slot-read-only
358                            for field-fn in field-fns
359                            when read-only
360                            collect `(not (fboundp '(setf ,field-fn))))
361                    t)
362                   t)))              
363         nil         nil
364         )))         )))

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

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