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") |
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. |
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))) |
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)))) |
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 |
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 |
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 |
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 |
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 |
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 |
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") |
644 |
(success success)) |
(success success)) |
645 |
|
|
646 |
|
|
647 |
|
|
648 |
|
|