107 |
(ignore-errors |
(ignore-errors |
108 |
(let ((p (ignore-errors (eval `(defpackage "H" (:use) |
(let ((p (ignore-errors (eval `(defpackage "H" (:use) |
109 |
(:shadow "foo")))))) |
(:shadow "foo")))))) |
110 |
(and |
(list |
111 |
(packagep p) |
(not (not (packagep p))) |
112 |
(equal (package-name p) "H") |
(equal (package-name p) "H") |
113 |
(equal (package-use-list p) nil) |
(equal (package-use-list p) nil) |
114 |
(equal (package-used-by-list p) nil) |
(equal (package-used-by-list p) nil) |
123 |
(list sym)))) |
(list sym)))) |
124 |
(equal (documentation p t) nil) |
(equal (documentation p t) nil) |
125 |
)))) |
)))) |
126 |
t) |
(t t t t t t t t)) |
127 |
|
|
128 |
;; Test defpackage shadow and null use, with several ways |
;; Test defpackage shadow and null use, with several ways |
129 |
;; of specifying the name of the shadowed symbol |
;; of specifying the name of the shadowed symbol |
130 |
(deftest defpackage-6 |
(deftest defpackage-6 |
131 |
(loop |
(loop |
132 |
for s in '(:|f| #\f) count |
for s in '(:|f| #\f) |
133 |
(not |
collect |
134 |
(ignore-errors |
(ignore-errors |
135 |
(ignore-errors (delete-package "H")) |
(ignore-errors (delete-package "H")) |
136 |
(let ((p (ignore-errors (eval `(defpackage "H" |
(let ((p (ignore-errors (eval `(defpackage "H" |
137 |
(:use) |
(:use) |
138 |
(:shadow ,s)))))) |
(:shadow ,s)))))) |
139 |
(and |
(list |
140 |
(packagep p) |
(not (not (packagep p))) |
141 |
(equal (package-name p) "H") |
(equal (package-name p) "H") |
142 |
(equal (package-use-list p) nil) |
(equal (package-use-list p) nil) |
143 |
(equal (package-used-by-list p) nil) |
(equal (package-used-by-list p) nil) |
144 |
(equal (package-nicknames p) nil) |
(equal (package-nicknames p) nil) |
145 |
(eql (num-symbols-in-package p) 1) |
(eql (num-symbols-in-package p) 1) |
146 |
(multiple-value-bind (sym access) |
(multiple-value-bind (sym access) |
147 |
(find-symbol "f" p) |
(find-symbol "f" p) |
148 |
(and (eq access :internal) |
(and (eq access :internal) |
149 |
(equal (symbol-name sym) "f") |
(equal (symbol-name sym) "f") |
150 |
(equal (symbol-package sym) p) |
(equal (symbol-package sym) p) |
151 |
(equal (package-shadowing-symbols p) |
(equal (package-shadowing-symbols p) |
152 |
(list sym)))) |
(list sym)))) |
153 |
(equal (documentation p t) nil) |
(equal (documentation p t) nil) |
154 |
))))) |
)))) |
155 |
0) |
((t t t t t t t t) |
156 |
|
(t t t t t t t t))) |
157 |
|
|
158 |
|
|
159 |
;; Testing defpackage with shadowing-import-from. |
;; Testing defpackage with shadowing-import-from. |
160 |
;; Test several ways of specifying the symbol name |
;; Test several ways of specifying the symbol name |
161 |
(deftest defpackage-7 |
(deftest defpackage-7 |
162 |
(progn |
(progn |
163 |
(ignore-errors (delete-package "H")) |
(ignore-errors (delete-package "H")) |
164 |
(ignore-errors (delete-package "G")) |
(ignore-errors (delete-package "G")) |
165 |
(let ((pg (make-package "G" :use nil))) |
(let ((pg (make-package "G" :use nil))) |
166 |
;; Populate package G with several symbols |
;; Populate package G with several symbols |
167 |
(export (intern "A" pg) pg) |
(export (intern "A" pg) pg) |
168 |
(export (intern "foo" pg) pg) |
(export (intern "foo" pg) pg) |
169 |
(intern "bar" pg) |
(intern "bar" pg) |
170 |
;; Do test with several ways of specifying the |
;; Do test with several ways of specifying the |
171 |
;; shadowing-imported symbol |
;; shadowing-imported symbol |
172 |
(loop |
(loop |
173 |
for n in '("A" :|A| #\A) count |
for n in '("A" :|A| #\A) |
174 |
(not |
collect |
175 |
(ignore-errors |
(ignore-errors |
176 |
(ignore-errors (delete-package "H")) |
(ignore-errors (delete-package "H")) |
177 |
(let ((p (ignore-errors |
(let ((p (ignore-errors |
178 |
(eval |
(eval |
179 |
`(defpackage "H" |
`(defpackage "H" |
180 |
(:use) |
(:use) |
181 |
(:shadowing-import-from "G" ,n)))))) |
(:shadowing-import-from "G" ,n)))))) |
182 |
(and |
(list |
183 |
(packagep p) |
(not (not (packagep p))) |
184 |
(equal (package-name p) "H") |
(equal (package-name p) "H") |
185 |
(equal (package-use-list p) nil) |
(equal (package-use-list p) nil) |
186 |
(equal (package-used-by-list p) nil) |
(equal (package-used-by-list p) nil) |
187 |
(equal (package-nicknames p) nil) |
(equal (package-nicknames p) nil) |
188 |
(eql (num-symbols-in-package p) 1) |
(eql (num-symbols-in-package p) 1) |
189 |
(multiple-value-bind (sym access) |
(multiple-value-bind (sym access) |
190 |
(find-symbol "A" p) |
(find-symbol "A" p) |
191 |
(and (eq access :internal) |
(and (eq access :internal) |
192 |
(equal (symbol-name sym) "A") |
(equal (symbol-name sym) "A") |
193 |
(equal (symbol-package sym) pg) |
(equal (symbol-package sym) pg) |
194 |
(equal (package-shadowing-symbols p) |
(equal (package-shadowing-symbols p) |
195 |
(list sym)))) |
(list sym)))) |
196 |
(equal (documentation p t) nil) |
(equal (documentation p t) nil) |
197 |
))))))) |
)))))) |
198 |
0) |
((t t t t t t t t) |
199 |
|
(t t t t t t t t) |
200 |
|
(t t t t t t t t))) |
201 |
|
|
202 |
;; Test import-from option |
;; Test import-from option |
203 |
;; Test for each way of specifying the imported symbol name, |
;; Test for each way of specifying the imported symbol name, |
209 |
(ignore-errors (delete-package "G")) |
(ignore-errors (delete-package "G")) |
210 |
(let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C"))))) |
(let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C"))))) |
211 |
(loop |
(loop |
212 |
for pn in '("G" #:|G| #\G) sum |
for pn in '("G" #:|G| #\G) |
213 |
(loop |
collect |
214 |
for n in '("B" #:|B| #\B) count |
(loop |
215 |
(not |
for n in '("B" #:|B| #\B) |
216 |
(ignore-errors |
collect |
217 |
(ignore-errors (delete-package "H")) |
(ignore-errors |
218 |
(let ((p (ignore-errors |
(ignore-errors (delete-package "H")) |
219 |
(eval `(defpackage |
(let ((p (ignore-errors |
220 |
"H" (:use) |
(eval `(defpackage |
221 |
(:import-from ,pn ,n "A")))))) |
"H" (:use) |
222 |
(and |
(:import-from ,pn ,n "A")))))) |
223 |
(packagep p) |
(list |
224 |
(equal (package-name p) "H") |
(not (not (packagep p))) |
225 |
(equal (package-use-list p) nil) |
(equal (package-name p) "H") |
226 |
(equal (package-used-by-list p) nil) |
(equal (package-use-list p) nil) |
227 |
(equal (package-nicknames p) nil) |
(equal (package-used-by-list p) nil) |
228 |
(equal (package-shadowing-symbols p) nil) |
(equal (package-nicknames p) nil) |
229 |
(eql (num-symbols-in-package p) 2) |
(equal (package-shadowing-symbols p) nil) |
230 |
(multiple-value-bind (sym access) |
(eql (num-symbols-in-package p) 2) |
231 |
(find-symbol "A" p) |
(multiple-value-bind (sym access) |
232 |
(and (eq access :internal) |
(find-symbol "A" p) |
233 |
(equal (symbol-name sym) "A") |
(and (eq access :internal) |
234 |
(equal (symbol-package sym) pg))) |
(equal (symbol-name sym) "A") |
235 |
(multiple-value-bind (sym access) |
(equal (symbol-package sym) pg))) |
236 |
(find-symbol "B" p) |
(multiple-value-bind (sym access) |
237 |
(and (eq access :internal) |
(find-symbol "B" p) |
238 |
(equal (symbol-name sym) "B") |
(and (eq access :internal) |
239 |
(equal (symbol-package sym) pg))) |
(equal (symbol-name sym) "B") |
240 |
(equal (documentation p t) nil) |
(equal (symbol-package sym) pg))) |
241 |
)))))))) |
(equal (documentation p t) nil) |
242 |
0) |
))))))) |
243 |
|
(((t t t t t t t t t) (t t t t t t t t t) (t t t t t t t t t)) |
244 |
|
((t t t t t t t t t) (t t t t t t t t t) (t t t t t t t t t)) |
245 |
|
((t t t t t t t t t) (t t t t t t t t t) (t t t t t t t t t)))) |
246 |
|
|
247 |
;; Test defpackage with export option |
;; Test defpackage with export option |
248 |
|
|
249 |
(deftest defpackage-9 |
(deftest defpackage-9 |
250 |
(progn |
(progn |
251 |
(loop |
(loop |
252 |
for n in '("Z" #:|Z| #\Z) count |
for n in '("Z" #:|Z| #\Z) |
253 |
(not |
collect |
254 |
(ignore-errors |
(ignore-errors |
255 |
(ignore-errors (delete-package "H")) |
(ignore-errors (delete-package "H")) |
256 |
(let ((p (ignore-errors |
(let ((p (ignore-errors |
257 |
(eval `(defpackage |
(eval `(defpackage |
258 |
"H" |
"H" |
259 |
(:export "Q" ,n "R") (:use)))))) |
(:export "Q" ,n "R") (:use)))))) |
260 |
(and |
(list |
261 |
(packagep p) |
(not (not (packagep p))) |
262 |
(equal (package-name p) "H") |
(equal (package-name p) "H") |
263 |
(equal (package-use-list p) nil) |
(equal (package-use-list p) nil) |
264 |
(equal (package-used-by-list p) nil) |
(equal (package-used-by-list p) nil) |
265 |
(equal (package-nicknames p) nil) |
(equal (package-nicknames p) nil) |
266 |
(equal (package-shadowing-symbols p) nil) |
(equal (package-shadowing-symbols p) nil) |
267 |
(eql (num-symbols-in-package p) 3) |
(eql (num-symbols-in-package p) 3) |
268 |
(loop |
(loop |
269 |
for s in '("Q" "Z" "R") do |
for s in '("Q" "Z" "R") do |
270 |
(unless |
(unless |
271 |
(multiple-value-bind (sym access) |
(multiple-value-bind (sym access) |
272 |
(find-symbol s p) |
(find-symbol s p) |
273 |
(and (eq access :external) |
(and (eq access :external) |
274 |
(equal (symbol-name sym) s) |
(equal (symbol-name sym) s) |
275 |
(equal (symbol-package sym) p))) |
(equal (symbol-package sym) p))) |
276 |
(return nil)) |
(return nil)) |
277 |
finally (return t)) |
finally (return t)) |
278 |
)))))) |
))))) |
279 |
0) |
((t t t t t t t t)(t t t t t t t t)(t t t t t t t t))) |
280 |
|
|
281 |
;; Test defpackage with the intern option |
;; Test defpackage with the intern option |
282 |
|
|
283 |
(deftest defpackage-10 |
(deftest defpackage-10 |
284 |
(progn |
(progn |
285 |
(loop |
(loop |
286 |
for n in '("Z" #:|Z| #\Z) count |
for n in '("Z" #:|Z| #\Z) |
287 |
(not |
collect |
288 |
(ignore-errors |
(ignore-errors |
289 |
(ignore-errors (delete-package "H")) |
(ignore-errors (delete-package "H")) |
290 |
(let ((p (ignore-errors |
(let ((p (ignore-errors |
291 |
(eval `(defpackage |
(eval `(defpackage |
292 |
"H" |
"H" |
293 |
(:intern "Q" ,n "R") (:use)))))) |
(:intern "Q" ,n "R") (:use)))))) |
294 |
(and |
(list |
295 |
(packagep p) |
(not (not (packagep p))) |
296 |
(equal (package-name p) "H") |
(equal (package-name p) "H") |
297 |
(equal (package-use-list p) nil) |
(equal (package-use-list p) nil) |
298 |
(equal (package-used-by-list p) nil) |
(equal (package-used-by-list p) nil) |
299 |
(equal (package-nicknames p) nil) |
(equal (package-nicknames p) nil) |
300 |
(equal (package-shadowing-symbols p) nil) |
(equal (package-shadowing-symbols p) nil) |
301 |
(eql (num-symbols-in-package p) 3) |
(eql (num-symbols-in-package p) 3) |
302 |
(loop |
(loop |
303 |
for s in '("Q" "Z" "R") do |
for s in '("Q" "Z" "R") do |
304 |
(unless |
(unless |
305 |
(multiple-value-bind (sym access) |
(multiple-value-bind (sym access) |
306 |
(find-symbol s p) |
(find-symbol s p) |
307 |
(and (eq access :internal) |
(and (eq access :internal) |
308 |
(equal (symbol-name sym) s) |
(equal (symbol-name sym) s) |
309 |
(equal (symbol-package sym) p))) |
(equal (symbol-package sym) p))) |
310 |
(return nil)) |
(return nil)) |
311 |
finally (return t)) |
finally (return t)) |
312 |
)))))) |
))))) |
313 |
0) |
((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) |
314 |
|
|
315 |
;; Test defpackage with size |
;; Test defpackage with size |
316 |
|
|
317 |
(deftest defpackage-11 |
(deftest defpackage-11 |
318 |
(ignore-errors |
(ignore-errors |
319 |
(ignore-errors (delete-package "H")) |
(ignore-errors (delete-package "H")) |
320 |
(let ((p (ignore-errors |
(let ((p (ignore-errors |
321 |
(eval '(defpackage "H" (:use) (:size 0)))))) |
(eval '(defpackage "H" (:use) (:size 0)))))) |
322 |
(and |
(list |
323 |
(packagep p) |
(not (not (packagep p))) |
324 |
(equal (package-name p) "H") |
(equal (package-name p) "H") |
325 |
(equal (package-use-list p) nil) |
(equal (package-use-list p) nil) |
326 |
(equal (package-used-by-list p) nil) |
(equal (package-used-by-list p) nil) |
327 |
(equal (package-nicknames p) nil) |
(equal (package-nicknames p) nil) |
328 |
(equal (package-shadowing-symbols p) nil) |
(equal (package-shadowing-symbols p) nil) |
329 |
(zerop (num-symbols-in-package p))))) |
(not (not (zerop (num-symbols-in-package p))))))) |
330 |
t) |
(t t t t t t t)) |
331 |
|
|
332 |
(deftest defpackage-12 |
(deftest defpackage-12 |
333 |
(ignore-errors |
(ignore-errors |
334 |
(ignore-errors (delete-package "H")) |
(ignore-errors (delete-package "H")) |
335 |
(let ((p (ignore-errors |
(let ((p (ignore-errors |
336 |
(eval '(defpackage "H" (:use) (:size 10000)))))) |
(eval '(defpackage "H" (:use) (:size 10000)))))) |
337 |
(and |
(list |
338 |
(packagep p) |
(not (not (packagep p))) |
339 |
(equal (package-name p) "H") |
(equal (package-name p) "H") |
340 |
(equal (package-use-list p) nil) |
(equal (package-use-list p) nil) |
341 |
(equal (package-used-by-list p) nil) |
(equal (package-used-by-list p) nil) |
342 |
(equal (package-nicknames p) nil) |
(equal (package-nicknames p) nil) |
343 |
(equal (package-shadowing-symbols p) nil) |
(equal (package-shadowing-symbols p) nil) |
344 |
(zerop (num-symbols-in-package p))))) |
(not (not (zerop (num-symbols-in-package p))))))) |
345 |
t) |
(t t t t t t t)) |
346 |
|
|
347 |
;; defpackage error handling |
;; defpackage error handling |
348 |
|
|
349 |
;; Repeated size field should cause a program-error |
;; Repeated size field should cause a program-error |
350 |
(deftest defpackage-13 |
(deftest defpackage-13 |
351 |
(progn |
(progn |
352 |
(ignore-errors (delete-package "H")) |
(ignore-errors (delete-package "H")) |
353 |
(handler-case |
(handler-case |
354 |
(eval '(defpackage "H" (:use) (:size 10) (:size 20))) |
(eval '(defpackage "H" (:use) (:size 10) (:size 20))) |
355 |
(program-error () 'program-error) |
(program-error () 'program-error) |
356 |
(error (c) c))) |
(error (c) c))) |
357 |
program-error) |
program-error) |
358 |
|
|
359 |
;; Repeated documentation field should cause a program-error |
;; Repeated documentation field should cause a program-error |
369 |
program-error) |
program-error) |
370 |
|
|
371 |
;; When a nickname refers to an existing package or nickname, |
;; When a nickname refers to an existing package or nickname, |
372 |
;; signal a program-error |
;; signal a package-error |
373 |
|
|
374 |
(deftest defpackage-15 |
(deftest defpackage-15 |
375 |
(progn |
(progn |
377 |
(handler-case |
(handler-case |
378 |
(eval '(defpackage "H" (:use) |
(eval '(defpackage "H" (:use) |
379 |
(:nicknames "A"))) |
(:nicknames "A"))) |
380 |
(program-error () 'program-error) |
(package-error () 'package-error) |
381 |
(error (c) c))) |
(error (c) c))) |
382 |
program-error) |
package-error) |
383 |
|
|
384 |
(deftest defpackage-16 |
(deftest defpackage-16 |
385 |
(progn |
(progn |
387 |
(handler-case |
(handler-case |
388 |
(eval '(defpackage "H" (:use) |
(eval '(defpackage "H" (:use) |
389 |
(:nicknames "Q"))) |
(:nicknames "Q"))) |
390 |
(program-error () 'program-error) |
(package-error () 'package-error) |
391 |
(error (c) c))) |
(error (c) c))) |
392 |
program-error) |
package-error) |
393 |
|
|
394 |
;; Names in :shadow, :shadowing-import-from, :import-from, and :intern |
;; Names in :shadow, :shadowing-import-from, :import-from, and :intern |
395 |
;; must be disjoint, or a package-error is signalled. |
;; must be disjoint, or a package-error is signalled. |