/[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.13 by pfdietz, Fri Jan 10 08:21:40 2003 UTC revision 1.14 by pfdietz, Tue Jan 14 11:38:07 2003 UTC
# Line 10  Line 10 
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
# Line 285  do the defstruct." Line 285  do the defstruct."
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
# Line 317  do the defstruct." Line 326  do the defstruct."
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))
# Line 357  do the defstruct." Line 391  do the defstruct."
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

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.14

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