/[gcl]/gcl/ansi-tests/with-package-iterator.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/with-package-iterator.lsp

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

revision 1.2 by pfdietz, Tue Jun 22 12:40:35 2004 UTC revision 1.3 by pfdietz, Sun Aug 29 22:03:24 2004 UTC
# Line 54  Line 54 
54    (with-package-iterator-inherited (list (find-package "A")))    (with-package-iterator-inherited (list (find-package "A")))
55    t)    t)
56    
 ;;; Check that if no access symbols are provided, a program error is  
 ;;; raised  
 #|  
57  (deftest with-package-iterator.11  (deftest with-package-iterator.11
58      (handler-case    (signals-error
59          (progn     (with-package-iterator (x "COMMON-LISP-USER"))
60            (test-with-package-iterator (list (find-package "COMMON-LISP-USER")))     program-error)
           nil)  
       (program-error () t)  
       (error (c) c))  
   t)  
 |#  
   
 ;;; Paul Werkowski" <pw@snoopy.mv.com> pointed out that  
 ;;; that test is broken.  Here's a version of the replacement  
 ;;; he suggested.  
 ;;  
 ;;; I'm not sure if this is correct either; it depends on  
 ;;; whether with-package-iterator should signal the error  
 ;;; at macro expansion time or at run time.  
 ;;  
   
 (deftest with-package-iterator.11  
   (handler-case (macroexpand-1  
                  '(with-package-iterator (x "COMMON-LISP-USER")))  
                 (program-error () t)  
                 (error (c) c))  
61    t)    t)
62    
63  ;;; Apply to all packages  ;;; Apply to all packages
# Line 122  Line 99 
99    
100  (def-macro-test with-package-iterator.error.1  (def-macro-test with-package-iterator.error.1
101    (with-package-iterator (x "CL" :external) nil))    (with-package-iterator (x "CL" :external) nil))
102    
103    
104    ;;; Specialized sequence tests
105    
106    (defmacro def-with-package-iterator-test (test-name name-form)
107      `(deftest ,test-name
108         (let ((name ,name-form))
109           (safely-delete-package name)
110           (let* ((p (make-package name :use nil))
111                  (result nil)
112                  (s (intern "X" p)))
113             (with-package-iterator
114              (x name :internal)
115              (loop
116               (multiple-value-bind
117                   (good? sym)
118                   (x)
119                   (unless good?
120                     (safely-delete-package name)
121                     (return (equalt (list s) result)))
122                 (push sym result))))))
123         t))
124    
125    (def-with-package-iterator-test with-package-iterator.15
126      (make-array 5 :initial-contents "TEST1"
127                  :element-type 'base-char))
128    
129    (def-with-package-iterator-test with-package-iterator.16
130      (make-array 8 :initial-contents "TEST1XXX"
131                  :fill-pointer 5
132                  :element-type 'base-char))
133    
134    (def-with-package-iterator-test with-package-iterator.17
135      (make-array 8 :initial-contents "TEST1XXX"
136                  :fill-pointer 5
137                  :element-type 'character))
138    
139    (def-with-package-iterator-test with-package-iterator.18
140      (make-array 5 :initial-contents "TEST1"
141                  :adjustable t
142                  :element-type 'base-char))
143    
144    (def-with-package-iterator-test with-package-iterator.19
145      (make-array 5 :initial-contents "TEST1"
146                  :adjustable t
147                  :element-type 'character))
148    
149    (def-with-package-iterator-test with-package-iterator.20
150      (let* ((etype 'base-char)
151             (name0 (make-array 10 :initial-contents "XTEST1YzYY"
152                                :element-type etype)))
153        (make-array 5 :element-type etype
154                    :displaced-to name0
155                    :displaced-index-offset 1)))
156    
157    (def-with-package-iterator-test with-package-iterator.21
158      (let* ((etype 'character)
159             (name0 (make-array 10 :initial-contents "XTEST1YzYY"
160                                :element-type etype)))
161        (make-array 5 :element-type etype
162                    :displaced-to name0
163                    :displaced-index-offset 1)))

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