/[gcl]/gcl/ansi-tests/packages-16.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/packages-16.lsp

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

revision 1.4 by pfdietz, Sat Oct 12 11:47:00 2002 UTC revision 1.5 by pfdietz, Thu Oct 17 13:16:56 2002 UTC
# Line 14  Line 14 
14  ;; we don't examine it here.  ;; we don't examine it here.
15  ;; Try several ways of specifying the package name.  ;; Try several ways of specifying the package name.
16  (deftest defpackage-1  (deftest defpackage-1
17      (handler-case    (handler-case
18          (loop     (loop
19              for n in '("H" #:|H| #\H) count      for n in '("H" #:|H| #\H) count
20                (not      (not
21                 (progn       (progn
22                   (ignore-errors (delete-package "H"))         (ignore-errors (delete-package "H"))
23                   (let ((p (ignore-errors (eval `(defpackage ,n)))))         (let ((p (ignore-errors (eval `(defpackage ,n)))))
24                     (and           (and
25                      (packagep p)            (packagep p)
26                      (equal (package-name p)              "H")            (equal (package-name p)              "H")
27                      ;; (equal (package-use-list p)          nil)            ;; (equal (package-use-list p)          nil)
28                      (equal (package-used-by-list p)      nil)            (equal (package-used-by-list p)      nil)
29                      (equal (package-nicknames p)         nil)            (equal (package-nicknames p)         nil)
30                      (equal (package-shadowing-symbols p) nil)            (equal (package-shadowing-symbols p) nil)
31                      (null (documentation p t))            (null (documentation p t))
32                      )))))            )))))
33        (error (c) c))     (error (c) c))
34    0)    0)
35    
36  ;; Test :nicknames option  ;; Test :nicknames option
37  ;; Do not check use-list, because it is implementation dependent  ;; Do not check use-list, because it is implementation dependent
38  ;; Try several ways of specifying a nickname.  ;; Try several ways of specifying a nickname.
39  (deftest defpackage-2  (deftest defpackage-2
40      (loop    (loop
41          for n in '("I" #:|I| #\I) count     for n in '("I" #:|I| #\I) count
42            (not     (not
43             (ignore-errors      (ignore-errors
44              (progn        (progn
45                (ignore-errors (delete-package "H"))          (ignore-errors (delete-package "H"))
46                (let ((p (ignore-errors          (let ((p (ignore-errors
47                          (eval `(defpackage "H" (:nicknames ,n "J"))))))                     (eval `(defpackage "H" (:nicknames ,n "J"))))))
48                  (and            (and
49                   (packagep p)             (packagep p)
50                   (equal (package-name p)              "H")             (equal (package-name p)              "H")
51                   ;; (equal (package-use-list p)          nil)             ;; (equal (package-use-list p)          nil)
52                   (equal (package-used-by-list p)      nil)             (equal (package-used-by-list p)      nil)
53                   (equal (sort (copy-list (package-nicknames p))             (equal (sort (copy-list (package-nicknames p))
54                                #'string<)                          #'string<)
55                          '("I" "J"))                    '("I" "J"))
56                   (equal (package-shadowing-symbols p) nil)             (equal (package-shadowing-symbols p) nil)
57                   (null (documentation p t))             (null (documentation p t))
58                   ))))))             ))))))
59      0)    0)
60    
61  ;; Test defpackage with documentation option  ;; Test defpackage with documentation option
62  ;; Do not check use-list, because it is implementation dependent  ;; Do not check use-list, because it is implementation dependent
63  (deftest defpackage-3  (deftest defpackage-3
64       (progn    (progn
65        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
66        (ignore-errors      (ignore-errors
67         (let ((p (eval '(defpackage "H" (:documentation "This is a doc string")))))        (let ((p (eval '(defpackage "H" (:documentation "This is a doc string")))))
68           (and          (and
69            (packagep p)           (packagep p)
70            (equal (package-name p)              "H")           (equal (package-name p)              "H")
71            ;; (equal (package-use-list p)          nil)           ;; (equal (package-use-list p)          nil)
72            (equal (package-used-by-list p)      nil)           (equal (package-used-by-list p)      nil)
73            (equal (package-nicknames p)  nil)           (equal (package-nicknames p)   nil)
74            (equal (package-shadowing-symbols p) nil)           (equal (package-shadowing-symbols p) nil)
75            (equal (documentation p t)           (equal (documentation p t) "This is a doc string")
76                   "This is a doc string")           t))))
           ))))  
77    t)    t)
78    
79  ;; Check use argument  ;; Check use argument
80  ;; Try several ways of specifying the package to be used  ;; Try several ways of specifying the package to be used
81  (deftest defpackage-4  (deftest defpackage-4
82      (loop    (loop
83          for n in '("A" :|A| #\A) count     for n in '("A" :|A| #\A) count
84            (not     (not
85             (ignore-errors      (ignore-errors
86              (progn        (progn
87                (ignore-errors (delete-package "H"))          (ignore-errors (delete-package "H"))
88                (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n))))))          (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n))))))
89                  (and            (and
90                   (packagep p)             (packagep p)
91                   (equal (package-name p)              "H")             (equal (package-name p)              "H")
92                   (equal (package-use-list p)          (list (find-package "A")))             (equal (package-use-list p)          (list (find-package "A")))
93                   (equal (package-used-by-list p)      nil)             (equal (package-used-by-list p)      nil)
94                   (equal (package-nicknames p)         nil)             (equal (package-nicknames p)         nil)
95                   (equal (package-shadowing-symbols p) nil)             (equal (package-shadowing-symbols p) nil)
96                   (eql (num-symbols-in-package p)             (eql (num-symbols-in-package p)
97                        (num-external-symbols-in-package "A"))                  (num-external-symbols-in-package "A"))
98                   (equal (documentation p t)             nil)             (equal (documentation p t)             nil)
99                   ))))))             ))))))
100    0)    0)
101    
102  ;; Test defpackage shadow option, and null use  ;; Test defpackage shadow option, and null use
103  (deftest defpackage-5  (deftest defpackage-5
104      (progn    (progn
105        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
106        (ignore-errors      (ignore-errors
107         (let ((p (ignore-errors (eval `(defpackage "H" (:use)        (let ((p (ignore-errors (eval `(defpackage "H" (:use)
108                                          (:shadow "foo"))))))                                         (:shadow "foo"))))))
109            (mapcar
110             #'notnot
111           (list           (list
112            (not (not (packagep p)))            (not (not (packagep p)))
113            (equal (package-name p)              "H")            (equal (package-name p)              "H")
# Line 115  Line 116 
116            (equal (package-nicknames p)         nil)            (equal (package-nicknames p)         nil)
117            (eql (num-symbols-in-package p) 1)            (eql (num-symbols-in-package p) 1)
118            (multiple-value-bind (sym access)            (multiple-value-bind (sym access)
119                                 (find-symbol "foo" p)                (find-symbol "foo" p)
120                                 (and (eq access :internal)              (and (eqt access :internal)
121                                      (equal (symbol-name sym) "foo")                   (equal (symbol-name sym) "foo")
122                                      (equal (symbol-package sym) p)                   (equal (symbol-package sym) p)
123                                      (equal (package-shadowing-symbols p)                   (equal (package-shadowing-symbols p)
124                                             (list sym))))                          (list sym))))
125            (equal (documentation p t)             nil)            (equal (documentation p t)             nil)
126            ))))           )))))
127      (t t t t t t t t))    (t t t t t t t t))
128    
129  ;; Test defpackage shadow and null use, with several ways  ;; Test defpackage shadow and null use, with several ways
130  ;; of specifying the name of the shadowed symbol  ;; of specifying the name of the shadowed symbol
131  (deftest defpackage-6  (deftest defpackage-6
132      (loop    (loop
133          for s in '(:|f| #\f)     for s in '(:|f| #\f)
134          collect     collect
135          (ignore-errors     (ignore-errors
136            (ignore-errors (delete-package "H"))       (ignore-errors (delete-package "H"))
137            (let ((p (ignore-errors (eval `(defpackage "H"       (let ((p (ignore-errors (eval `(defpackage "H"
138                                             (:use)                                        (:use)
139                                             (:shadow ,s))))))                                        (:shadow ,s))))))
140              (list         (mapcar
141               (not (not (packagep p)))          #'notnot
142               (equal (package-name p)              "H")          (list
143               (equal (package-use-list p)          nil)           (not (not (packagep p)))
144               (equal (package-used-by-list p)      nil)           (equal (package-name p)              "H")
145               (equal (package-nicknames p)         nil)           (equal (package-use-list p)          nil)
146               (eql (num-symbols-in-package p) 1)           (equal (package-used-by-list p)      nil)
147               (multiple-value-bind (sym access)           (equal (package-nicknames p)         nil)
148                   (find-symbol "f" p)           (eql (num-symbols-in-package p) 1)
149                 (and (eq access :internal)           (multiple-value-bind (sym access)
150                      (equal (symbol-name sym) "f")               (find-symbol "f" p)
151                      (equal (symbol-package sym) p)             (and (eqt access :internal)
152                      (equal (package-shadowing-symbols p)                  (equal (symbol-name sym) "f")
153                             (list sym))))                  (equal (symbol-package sym) p)
154               (equal (documentation p t)             nil)                  (equal (package-shadowing-symbols p)
155               ))))                         (list sym))))
156      ((t t t t t t t t)           (equal (documentation p t)             nil)
157       (t t t t t t t t)))           )))))
158      ((t t t t t t t t)
159       (t t t t t t t t)))
160    
161    
162  ;; Testing defpackage with shadowing-import-from.  ;; Testing defpackage with shadowing-import-from.
# Line 179  Line 182 
182                       `(defpackage "H"                       `(defpackage "H"
183                          (:use)                          (:use)
184                          (:shadowing-import-from "G" ,n))))))                          (:shadowing-import-from "G" ,n))))))
185             (list             (mapcar
186              (not (not (packagep p)))              #'notnot
187              (equal (package-name p)              "H")              (list
188              (equal (package-use-list p)          nil)               (not (not (packagep p)))
189              (equal (package-used-by-list p)      nil)               (equal (package-name p)              "H")
190              (equal (package-nicknames p)         nil)               (equal (package-use-list p)          nil)
191              (eql (num-symbols-in-package p) 1)               (equal (package-used-by-list p)      nil)
192              (multiple-value-bind (sym access)               (equal (package-nicknames p)         nil)
193                  (find-symbol "A" p)               (eql (num-symbols-in-package p) 1)
194                (and (eq access :internal)               (multiple-value-bind (sym access)
195                     (equal (symbol-name sym) "A")                   (find-symbol "A" p)
196                     (equal (symbol-package sym) pg)                 (and (eqt access :internal)
197                     (equal (package-shadowing-symbols p)                      (equal (symbol-name sym) "A")
198                            (list sym))))                      (equal (symbol-package sym) pg)
199              (equal (documentation p t)             nil)                      (equal (package-shadowing-symbols p)
200              ))))))                             (list sym))))
201                 (equal (documentation p t)             nil)
202                 )))))))
203    ((t t t t t t t t)    ((t t t t t t t t)
204     (t t t t t t t t)     (t t t t t t t t)
205     (t t t t t t t t)))     (t t t t t t t t)))
# Line 220  Line 225 
225                          (eval `(defpackage                          (eval `(defpackage
226                                   "H" (:use)                                   "H" (:use)
227                                   (:import-from ,pn ,n "A"))))))                                   (:import-from ,pn ,n "A"))))))
228                 (list                 (mapcar
229                  (not (not (packagep p)))                  #'notnot
230                  (equal (package-name p)              "H")                  (list
231                  (equal (package-use-list p)          nil)                   (not (not (packagep p)))
232                  (equal (package-used-by-list p)      nil)                   (equal (package-name p)              "H")
233                  (equal (package-nicknames p)         nil)                   (equal (package-use-list p)          nil)
234                  (equal (package-shadowing-symbols p) nil)                   (equal (package-used-by-list p)      nil)
235                  (eql (num-symbols-in-package p) 2)                   (equal (package-nicknames p)         nil)
236                  (multiple-value-bind (sym access)                   (equal (package-shadowing-symbols p) nil)
237                      (find-symbol "A" p)                   (eql (num-symbols-in-package p) 2)
238                    (and (eq access :internal)                   (multiple-value-bind (sym access)
239                         (equal (symbol-name sym) "A")                       (find-symbol "A" p)
240                         (equal (symbol-package sym) pg)))                     (and (eqt access :internal)
241                  (multiple-value-bind (sym access)                          (equal (symbol-name sym) "A")
242                      (find-symbol "B" p)                          (equal (symbol-package sym) pg)))
243                    (and (eq access :internal)                   (multiple-value-bind (sym access)
244                         (equal (symbol-name sym) "B")                       (find-symbol "B" p)
245                         (equal (symbol-package sym) pg)))                     (and (eqt access :internal)
246                  (equal (documentation p t)             nil)                          (equal (symbol-name sym) "B")
247                  )))))))                          (equal (symbol-package sym) pg)))
248                     (equal (documentation p t)             nil)
249                     ))))))))
250      (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))      (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))
251       ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))       ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))
252       ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))))       ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))))
# Line 257  Line 264 
264                    (eval `(defpackage                    (eval `(defpackage
265                             "H"                             "H"
266                             (:export "Q" ,n "R") (:use))))))                             (:export "Q" ,n "R") (:use))))))
267           (list           (mapcar
268            (not (not (packagep p)))            #'notnot
269            (equal (package-name p)              "H")            (list
270            (equal (package-use-list p)          nil)             (not (not (packagep p)))
271            (equal (package-used-by-list p)      nil)             (equal (package-name p)              "H")
272            (equal (package-nicknames p)         nil)             (equal (package-use-list p)          nil)
273            (equal (package-shadowing-symbols p) nil)             (equal (package-used-by-list p)      nil)
274            (eql (num-symbols-in-package p) 3)             (equal (package-nicknames p)         nil)
275            (loop             (equal (package-shadowing-symbols p) nil)
276             for s in '("Q" "Z" "R") do             (eql (num-symbols-in-package p) 3)
277             (unless             (loop
278                 (multiple-value-bind (sym access)              for s in '("Q" "Z" "R") do
279                     (find-symbol s p)              (unless
280                   (and (eq access :external)                  (multiple-value-bind (sym access)
281                        (equal (symbol-name sym) s)                      (find-symbol s p)
282                        (equal (symbol-package sym) p)))                    (and (eqt access :external)
283               (return nil))                         (equal (symbol-name sym) s)
284             finally (return t))                         (equal (symbol-package sym) p)))
285            )))))                (return nil))
286                finally (return t))
287               ))))))
288    ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t)))    ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t)))
289    
290  ;; Test defpackage with the intern option  ;; Test defpackage with the intern option
# Line 291  Line 300 
300                    (eval `(defpackage                    (eval `(defpackage
301                             "H"                             "H"
302                             (:intern "Q" ,n "R") (:use))))))                             (:intern "Q" ,n "R") (:use))))))
303           (list           (mapcar
304            (not (not (packagep p)))            #'notnot
305            (equal (package-name p)              "H")            (list
306            (equal (package-use-list p)          nil)             (not (not (packagep p)))
307            (equal (package-used-by-list p)      nil)             (equal (package-name p)              "H")
308            (equal (package-nicknames p)         nil)             (equal (package-use-list p)          nil)
309            (equal (package-shadowing-symbols p) nil)             (equal (package-used-by-list p)      nil)
310            (eql (num-symbols-in-package p) 3)             (equal (package-nicknames p)         nil)
311            (loop             (equal (package-shadowing-symbols p) nil)
312             for s in '("Q" "Z" "R") do             (eql (num-symbols-in-package p) 3)
313             (unless             (loop
314                 (multiple-value-bind (sym access)              for s in '("Q" "Z" "R") do
315                     (find-symbol s p)              (unless
316                   (and (eq access :internal)                  (multiple-value-bind (sym access)
317                        (equal (symbol-name sym) s)                      (find-symbol s p)
318                        (equal (symbol-package sym) p)))                    (and (eqt access :internal)
319               (return nil))                         (equal (symbol-name sym) s)
320             finally (return t))                         (equal (symbol-package sym) p)))
321            )))))                (return nil))
322                finally (return t))
323               ))))))
324    ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t)))    ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t)))
325    
326  ;; Test defpackage with size  ;; Test defpackage with size
# Line 319  Line 330 
330      (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
331      (let ((p (ignore-errors      (let ((p (ignore-errors
332                 (eval '(defpackage "H" (:use) (:size 0))))))                 (eval '(defpackage "H" (:use) (:size 0))))))
333        (list        (mapcar
334         (not (not (packagep p)))         #'notnot
335         (equal (package-name p)              "H")         (list
336         (equal (package-use-list p)          nil)          (packagep p)
337         (equal (package-used-by-list p)      nil)          (equal (package-name p)              "H")
338         (equal (package-nicknames p)         nil)          (equal (package-use-list p)          nil)
339         (equal (package-shadowing-symbols p) nil)          (equal (package-used-by-list p)      nil)
340         (not (not (zerop (num-symbols-in-package p)))))))          (equal (package-nicknames p)         nil)
341            (equal (package-shadowing-symbols p) nil)
342            (zerop (num-symbols-in-package p))))))
343    (t t t t t t t))    (t t t t t t t))
344    
345  (deftest defpackage-12  (deftest defpackage-12
# Line 334  Line 347 
347      (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
348      (let ((p (ignore-errors      (let ((p (ignore-errors
349                 (eval '(defpackage "H" (:use) (:size 10000))))))                 (eval '(defpackage "H" (:use) (:size 10000))))))
350        (list        (mapcar
351         (not (not (packagep p)))         #'notnot
352         (equal (package-name p)              "H")         (list
353         (equal (package-use-list p)          nil)          (packagep p)
354         (equal (package-used-by-list p)      nil)          (equal (package-name p)              "H")
355         (equal (package-nicknames p)         nil)          (equal (package-use-list p)          nil)
356         (equal (package-shadowing-symbols p) nil)          (equal (package-used-by-list p)      nil)
357         (not (not (zerop (num-symbols-in-package p)))))))          (equal (package-nicknames p)         nil)
358            (equal (package-shadowing-symbols p) nil)
359            (zerop (num-symbols-in-package p))))))
360    (t t t t t t t))    (t t t t t t t))
361    
362  ;; defpackage error handling  ;; defpackage error handling
# Line 358  Line 373 
373    
374  ;; Repeated documentation field should cause a program-error  ;; Repeated documentation field should cause a program-error
375  (deftest defpackage-14  (deftest defpackage-14
376      (progn    (progn
377        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
378        (handler-case      (handler-case
379            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
380                    (:documentation "foo")                (:documentation "foo")
381                    (:documentation "bar")))                (:documentation "bar")))
382          (program-error () 'program-error)       (program-error () 'program-error)
383          (error (c) c)))       (error (c) c)))
384    program-error)    program-error)
385    
386  ;; When a nickname refers to an existing package or nickname,  ;; When a nickname refers to an existing package or nickname,
387  ;; signal a package-error  ;; signal a package-error
388    
389  (deftest defpackage-15  (deftest defpackage-15
390      (progn    (progn
391        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
392        (handler-case      (handler-case
393            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
394                    (:nicknames "A")))                (:nicknames "A")))
395          (package-error () 'package-error)       (package-error () 'package-error)
396          (error (c) c)))       (error (c) c)))
397    package-error)    package-error)
398    
399  (deftest defpackage-16  (deftest defpackage-16
400      (progn    (progn
401        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
402        (handler-case      (handler-case
403            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
404                    (:nicknames "Q")))                (:nicknames "Q")))
405          (package-error () 'package-error)       (package-error () 'package-error)
406          (error (c) c)))       (error (c) c)))
407    package-error)    package-error)
408    
409  ;; Names in :shadow, :shadowing-import-from, :import-from, and :intern  ;; Names in :shadow, :shadowing-import-from, :import-from, and :intern
# Line 396  Line 411 
411    
412  ;; :shadow and :shadowing-import-from  ;; :shadow and :shadowing-import-from
413  (deftest defpackage-17  (deftest defpackage-17
414      (ignore-errors    (ignore-errors
415        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
416        (ignore-errors (delete-package "G"))      (ignore-errors (delete-package "G"))
417        (eval '(defpackage "G" (:use) (:export "A")))      (eval '(defpackage "G" (:use) (:export "A")))
418        (handler-case      (handler-case
419            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
420                    (:shadow "A")                (:shadow "A")
421                    (:shadowing-import-from "G" "A")))                (:shadowing-import-from "G" "A")))
422          (program-error () 'program-error)       (program-error () 'program-error)
423          (error (c) c)))       (error (c) c)))
424    program-error)    program-error)
425    
426  ;; :shadow and :import-from  ;; :shadow and :import-from
427  (deftest defpackage-18  (deftest defpackage-18
428      (ignore-errors    (ignore-errors
429        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
430        (ignore-errors (delete-package "G"))      (ignore-errors (delete-package "G"))
431        (eval '(defpackage "G" (:use) (:export "A")))      (eval '(defpackage "G" (:use) (:export "A")))
432        (handler-case      (handler-case
433            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
434                    (:shadow "A")                (:shadow "A")
435                    (:import-from "G" "A")))                (:import-from "G" "A")))
436          (program-error () 'program-error)       (program-error () 'program-error)
437          (error (c) c)))       (error (c) c)))
438    program-error)    program-error)
439    
440  ;; :shadow and :intern  ;; :shadow and :intern
441  (deftest defpackage-19  (deftest defpackage-19
442      (progn    (progn
443        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
444        (handler-case      (handler-case
445            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
446                    (:shadow "A")                (:shadow "A")
447                    (:intern "A")))                (:intern "A")))
448          (program-error () 'program-error)       (program-error () 'program-error)
449          (error (c) c)))       (error (c) c)))
450    program-error)    program-error)
451    
452  ;; :shadowing-import-from and :import-from  ;; :shadowing-import-from and :import-from
453  (deftest defpackage-20  (deftest defpackage-20
454      (ignore-errors    (ignore-errors
455        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
456        (ignore-errors (delete-package "G"))      (ignore-errors (delete-package "G"))
457        (eval '(defpackage "G" (:use) (:export "A")))      (eval '(defpackage "G" (:use) (:export "A")))
458        (handler-case      (handler-case
459            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
460                    (:shadowing-import-from "G" "A")                (:shadowing-import-from "G" "A")
461                    (:import-from "G" "A")))                (:import-from "G" "A")))
462          (program-error () 'program-error)       (program-error () 'program-error)
463          (error (c) c)))       (error (c) c)))
464    program-error)    program-error)
465    
466  ;; :shadowing-import-from and :intern  ;; :shadowing-import-from and :intern
467  (deftest defpackage-21  (deftest defpackage-21
468      (ignore-errors    (ignore-errors
469        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
470        (ignore-errors (delete-package "G"))      (ignore-errors (delete-package "G"))
471        (eval '(defpackage "G" (:use) (:export "A")))      (eval '(defpackage "G" (:use) (:export "A")))
472        (handler-case      (handler-case
473              (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
474                      (:shadowing-import-from "G" "A")                (:shadowing-import-from "G" "A")
475                      (:intern "A")))                (:intern "A")))
476            (program-error () 'program-error)       (program-error () 'program-error)
477            (error (c) c)))       (error (c) c)))
478    program-error)    program-error)
479    
480  ;; :import-from and :intern  ;; :import-from and :intern
481  (deftest defpackage-22  (deftest defpackage-22
482      (ignore-errors    (ignore-errors
483        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
484        (ignore-errors (delete-package "G"))      (ignore-errors (delete-package "G"))
485        (eval '(defpackage "G" (:use) (:export "A")))      (eval '(defpackage "G" (:use) (:export "A")))
486        (handler-case      (handler-case
487            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
488                    (:import-from "G" "A")                (:import-from "G" "A")
489                    (:intern "A")))                (:intern "A")))
490          (program-error () 'program-error)       (program-error () 'program-error)
491          (error (c) c)))       (error (c) c)))
492    program-error)    program-error)
493    
494  ;; Names given to :export and :intern must be disjoint,  ;; Names given to :export and :intern must be disjoint,
495  ;;  otherwise signal a program-error  ;;  otherwise signal a program-error
496  (deftest defpackage-23  (deftest defpackage-23
497      (ignore-errors    (ignore-errors
498        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
499        (handler-case      (handler-case
500            (eval '(defpackage "H" (:use)       (eval '(defpackage "H" (:use)
501                    (:export "A")                (:export "A")
502                    (:intern "A")))                (:intern "A")))
503          (program-error () 'program-error)       (program-error () 'program-error)
504          (error (c) c)))       (error (c) c)))
505    program-error)    program-error)
506    
507  ;; :shadowing-import-from signals a correctable package-error  ;; :shadowing-import-from signals a correctable package-error
508  ;;  if the symbol is not accessible in the named package  ;;  if the symbol is not accessible in the named package
509  (deftest defpackage-24  (deftest defpackage-24
510      (ignore-errors    (ignore-errors
511        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
512        (ignore-errors (delete-package "G"))      (ignore-errors (delete-package "G"))
513        (eval '(defpackage "G" (:use)))      (eval '(defpackage "G" (:use)))
514        (handler-case      (handler-case
515            (eval '(defpackage "H" (:shadowing-import-from "G" "NOT-THERE")))       (eval '(defpackage "H" (:shadowing-import-from "G" "NOT-THERE")))
516          (package-error (c)       (package-error (c)
517            (if (position 'abort (compute-restarts c)                      (if (position 'abort (compute-restarts c)
518                          :key #'restart-name :test-not #'eq)                                    :key #'restart-name :test-not #'eq)
519                'success                          'success
520              'fail))                        'fail))
521          (error (c) c)))       (error (c) c)))
522    success)    success)
523    
524  ;; :import-from signals a correctable package-error if a symbol with  ;; :import-from signals a correctable package-error if a symbol with
525  ;; the indicated name is not accessible in the package indicated  ;; the indicated name is not accessible in the package indicated
526    
527  (deftest defpackage-25  (deftest defpackage-25
528      (ignore-errors    (ignore-errors
529        (ignore-errors (delete-package "H"))      (ignore-errors (delete-package "H"))
530        (ignore-errors (delete-package "G"))      (ignore-errors (delete-package "G"))
531        (eval '(defpackage "G" (:use)))      (eval '(defpackage "G" (:use)))
532        (handler-case      (handler-case
533            (eval '(defpackage "H" (:import-from "G" "NOT-THERE")))       (eval '(defpackage "H" (:import-from "G" "NOT-THERE")))
534          (package-error (c)       (package-error (c)
535            (if (position 'abort (compute-restarts c)                      (if (position 'abort (compute-restarts c)
536                          :key #'restart-name :test-not #'eq)                                    :key #'restart-name :test-not #'eq)
537                'success                          'success
538              'fail))                        'fail))
539          (error (c) c)))       (error (c) c)))
540    success)    success)
541    
542  ;; A big test that combines all the options to defpackage  ;; A big test that combines all the options to defpackage
# Line 529  Line 544 
544  (deftest defpackage-26  (deftest defpackage-26
545    (ignore-errors    (ignore-errors
546      (flet      (flet
547          ((%do-it% (args)          ((%do-it%
548             (ignore-errors (delete-package "H"))            (args)
549             (ignore-errors (delete-package "G1"))            (ignore-errors (delete-package "H"))
550             (ignore-errors (delete-package "G2"))            (ignore-errors (delete-package "G1"))
551             (ignore-errors (delete-package "G3"))            (ignore-errors (delete-package "G2"))
552             (let ((pg1            (ignore-errors (delete-package "G3"))
553                    (progn            (let ((pg1
554                      (format t "Making G1...~%")                   (progn
555                      (eval '(defpackage "G1"                     (format t "Making G1...~%")
556                       (eval '(defpackage "G1"
557                              (:use)                              (:use)
558                              (:export "A" "B" "C")                              (:export "A" "B" "C")
559                              (:intern "D" "E" "F")))))                              (:intern "D" "E" "F")))))
560                   (pg2                  (pg2
561                    (progn                   (progn
562                      (format t "Making G2...~%")                     (format t "Making G2...~%")
563                      (eval '(defpackage "G2"                     (eval '(defpackage "G2"
564                              (:use)                              (:use)
565                              (:export "A" "D" "G")                              (:export "A" "D" "G")
566                              (:intern "E" "H" "I")))))                              (:intern "E" "H" "I")))))
567                   (pg3                  (pg3
568                    (progn                   (progn
569                      (format t "Making G3...~%")                     (format t "Making G3...~%")
570                      (eval '(defpackage "G3"                     (eval '(defpackage "G3"
571                              (:use)                              (:use)
572                              (:export "J" "K" "L")                              (:export "J" "K" "L")
573                              (:intern "M" "N" "O"))))))                              (:intern "M" "N" "O"))))))
574               (let ((p (eval (list* 'defpackage "H" (copy-tree args)))))              (let ((p (eval (list* 'defpackage "H" (copy-tree args)))))
575                 (prog ()                (prog
576                   (unless (packagep p) (return 1))                 ()
577                   (unless (equal (package-name p) "H") (return 2))                 (unless (packagep p) (return 1))
578                   (unless (equal (package-name pg1) "G1") (return 3))                 (unless (equal (package-name p) "H") (return 2))
579                   (unless (equal (package-name pg2) "G2") (return 4))                 (unless (equal (package-name pg1) "G1") (return 3))
580                   (unless (equal (package-name pg3) "G3") (return 5))                 (unless (equal (package-name pg2) "G2") (return 4))
581                   (unless                 (unless (equal (package-name pg3) "G3") (return 5))
582                       (equal (sort (copy-list (package-nicknames p)) #'string<)                 (unless
583                              '("H1" "H2"))                     (equal (sort (copy-list (package-nicknames p)) #'string<)
584                     (return 6))                            '("H1" "H2"))
585                     (return 6))
586                   (unless
587                       (or
588                        (equal (package-use-list p) (list pg1 pg2))
589                        (equal (package-use-list p) (list pg2 pg1)))
590                     (return 7))
591                   (unless (equal (package-used-by-list pg1) (list p))
592                     (return 8))
593                   (unless (equal (package-used-by-list pg2) (list p))
594                     (return 9))
595                   (when (package-used-by-list pg3) (return 10))
596                   (unless (equal (sort (mapcar #'symbol-name
597                                                (package-shadowing-symbols p))
598                                        #'string<)
599                                  '("A" "B"))
600                     (return 10))
601                   (let ((num 11))
602                   (unless                   (unless
603                       (or                       (every
604                        (equal (package-use-list p) (list pg1 pg2))                        #'(lambda (str acc pkg)
605                        (equal (package-use-list p) (list pg2 pg1)))                            (multiple-value-bind
606                     (return 7))                                (sym access)
607                   (unless (equal (package-used-by-list pg1) (list p))                                (find-symbol str p)
608                     (return 8))                              (or
609                   (unless (equal (package-used-by-list pg2) (list p))                               (and (or (not acc) (equal (symbol-name sym) str))
610                     (return 9))                                    (or (not acc) (equal (symbol-package sym) pkg))
611                   (when (package-used-by-list pg3) (return 10))                                    (equal access acc)
612                   (unless (equal (sort (mapcar #'symbol-name                                    (incf num))
613                                                (package-shadowing-symbols p))                               (progn
614                                        #'string<)                                 (format t
615                                  '("A" "B"))                                         "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%"
616                     (return 10))                                         str acc pkg sym access)
617                   (let ((num 11))                                 nil))))
618                     (unless                        (list "A" "B" "C" "D" "E" "F" "G"
619                         (every                              "H" "I" "J" "K" "L" "M" "N" "O")
620                          #'(lambda (str acc pkg)                        (list :internal :internal
621                              (multiple-value-bind                              :external :inherited
622                                  (sym access)                              nil nil
623                                  (find-symbol str p)                              :inherited :internal
624                                (or                              nil nil
625                                 (and (or (not acc) (equal (symbol-name sym) str))                              nil :external
626                                      (or (not acc) (equal (symbol-package sym) pkg))                              nil nil
627                                      (equal access acc)                              :internal)
628                                      (incf num))                        (list pg2 p pg1 pg2 nil nil
629                                 (progn                              pg2 p nil nil nil pg3
630                                   (format t                              nil nil pg3))
631                                           "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%"                     (return num)))
632                                           str acc pkg sym access)                 (return 'success))))))
                                  nil))))  
                         (list "A" "B" "C" "D" "E" "F" "G"  
                               "H" "I" "J" "K" "L" "M" "N" "O")  
                         (list :internal :internal  
                               :external :inherited  
                               nil nil  
                               :inherited :internal  
                               nil nil  
                               nil :external  
                               nil nil  
                               :internal)  
                         (list pg2 p pg1 pg2 nil nil  
                               pg2 p nil nil nil pg3  
                               nil nil pg3))  
                      (return num)))  
                  (return 'success))))))  
633        (let ((args '((:nicknames "H1" "H2")        (let ((args '((:nicknames "H1" "H2")
634                      (:use "G1" "G2")                      (:use "G1" "G2")
635                      (:shadow "B")                      (:shadow "B")
# Line 627  Line 644 
644    (success success))    (success success))
645    
646    
647    
648                

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