1 ;;;; miscellaneous tests of package-related stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (with-test (:name
:packages-sanely-nicknamed
)
15 (dolist (p (list-all-packages))
16 (let* ((nicks (package-nicknames p
))
17 (check (remove-duplicates nicks
:test
'string
=)))
18 (assert (= (length check
) (length nicks
))))))
21 (defvar *foo
* (find-package (coerce "FOO" 'base-string
)))
22 (rename-package "FOO" (make-array 0 :element-type nil
))
23 (assert (eq *foo
* (find-package "")))
24 (assert (delete-package ""))
27 (defvar *baz
* (rename-package "BAR" "BAZ"))
28 (assert (eq *baz
* (find-package "BAZ")))
29 (assert (delete-package *baz
*))
33 (package-error (c) (princ c
))
34 (:no-error
(&rest args
) (error "(EXPORT :FOO) returned ~S" args
)))
37 (assert (shadow #\a :foo
))
39 (defpackage :PACKAGE-DESIGNATOR-1
(:use
#.
(find-package :cl
)))
41 (defpackage :PACKAGE-DESIGNATOR-2
42 (:import-from
#.
(find-package :cl
) "+"))
44 (defpackage "EXAMPLE-INDIRECT"
45 (:import-from
"CL" "+"))
47 (defpackage "EXAMPLE-PACKAGE"
49 (:shadowing-import-from
"CL" "CAAR")
51 (:import-from
"CL" "CDR")
52 (:import-from
"EXAMPLE-INDIRECT" "+")
53 (:export
"CAR" "CDR" "EXAMPLE"))
55 (flet ((check-symbol (name expected-status expected-home-name
)
56 (multiple-value-bind (symbol status
)
57 (find-symbol name
"EXAMPLE-PACKAGE")
58 (let ((home (symbol-package symbol
))
59 (expected-home (find-package expected-home-name
)))
60 (assert (eql home expected-home
))
61 (assert (eql status expected-status
))))))
62 (check-symbol "CAR" :external
"EXAMPLE-PACKAGE")
63 (check-symbol "CDR" :external
"CL")
64 (check-symbol "EXAMPLE" :external
"EXAMPLE-PACKAGE")
65 (check-symbol "CAAR" :internal
"CL")
66 (check-symbol "+" :internal
"CL")
67 (check-symbol "CDDR" nil
"CL"))
69 (defpackage "TEST-ORIGINAL" (:nicknames
"A-NICKNAME"))
71 (assert-error (defpackage "A-NICKNAME"))
73 (assert (eql (find-package "A-NICKNAME")
74 (find-package "TEST-ORIGINAL")))
77 (defun sym (package name
)
78 (let ((package (or (find-package package
) package
)))
79 (multiple-value-bind (symbol status
)
80 (find-symbol name package
)
82 (package name symbol status
)
83 "No symbol with name ~A in ~S." name package symbol status
)
84 (values symbol status
))))
86 (defmacro with-name-conflict-resolution
((symbol &key restarted
)
88 "Resolves potential name conflict condition arising from FORM.
90 The conflict is resolved in favour of SYMBOL, a form which must
93 If RESTARTED is a symbol, it is bound for the BODY forms and set to T
94 if a restart was invoked."
95 (check-type restarted symbol
"a binding name")
96 (let ((%symbol
(copy-symbol 'symbol
)))
97 `(let (,@(when restarted
`((,restarted
)))
100 ((sb-ext:name-conflict
102 ,@(when restarted
`((setf ,restarted t
)))
103 (assert (member ,%symbol
(sb-ext:name-conflict-symbols condition
)))
104 (invoke-restart 'sb-ext
:resolve-conflict
,%symbol
))))
108 (defmacro with-packages
(specs &body forms
)
109 (let ((names (mapcar #'car specs
)))
112 (delete-packages ',names
)
113 ,@(mapcar (lambda (spec)
114 `(defpackage ,@spec
))
117 (delete-packages ',names
))))
119 (defun delete-packages (names)
121 (ignore-errors (delete-package p
))))
126 (with-test (:name
:use-package
.1)
127 (with-packages (("FOO" (:export
"SYM"))
128 ("BAR" (:export
"SYM"))
130 (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp
)
131 (use-package '("FOO" "BAR") "BAZ")
133 (is (eq (sym "BAR" "SYM")
134 (sym "BAZ" "SYM"))))))
136 (with-test (:name
:use-package
.2)
137 (with-packages (("FOO" (:export
"SYM"))
138 ("BAZ" (:use
) (:intern
"SYM")))
139 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
140 (use-package "FOO" "BAZ")
142 (is (eq (sym "FOO" "SYM")
143 (sym "BAZ" "SYM"))))))
145 (with-test (:name
:use-package
.2a
)
146 (with-packages (("FOO" (:export
"SYM"))
147 ("BAZ" (:use
) (:intern
"SYM")))
148 (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp
)
149 (use-package "FOO" "BAZ")
151 (is (equal (list (sym "BAZ" "SYM") :internal
)
152 (multiple-value-list (sym "BAZ" "SYM")))))))
154 (with-test (:name
:use-package-conflict-set
:fails-on
:sbcl
)
155 (with-packages (("FOO" (:export
"SYM"))
156 ("QUX" (:export
"SYM"))
157 ("BAR" (:intern
"SYM"))
158 ("BAZ" (:use
) (:import-from
"BAR" "SYM")))
159 (let ((conflict-set))
162 ((sb-ext:name-conflict
164 (setf conflict-set
(copy-list
165 (sb-ext:name-conflict-symbols condition
)))
167 (use-package '("FOO" "QUX") "BAZ")))
169 (sort conflict-set
#'string
<
170 :key
(lambda (symbol)
171 (package-name (symbol-package symbol
)))))
172 (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM"))
176 (with-test (:name
:export
.1)
177 (with-packages (("FOO" (:intern
"SYM"))
178 ("BAR" (:export
"SYM"))
179 ("BAZ" (:use
"FOO" "BAR")))
180 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
181 (export (sym "FOO" "SYM") "FOO")
183 (is (eq (sym "FOO" "SYM")
184 (sym "BAZ" "SYM"))))))
186 (with-test (:name
:export
.1a
)
187 (with-packages (("FOO" (:intern
"SYM"))
188 ("BAR" (:export
"SYM"))
189 ("BAZ" (:use
"FOO" "BAR")))
190 (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp
)
191 (export (sym "FOO" "SYM") "FOO")
193 (is (eq (sym "BAR" "SYM")
194 (sym "BAZ" "SYM"))))))
196 (with-test (:name
:export.ensure-exported
)
197 (with-packages (("FOO" (:intern
"SYM"))
198 ("BAR" (:export
"SYM"))
199 ("BAZ" (:use
"FOO" "BAR") (:IMPORT-FROM
"BAR" "SYM")))
200 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
201 (export (sym "FOO" "SYM") "FOO")
203 (is (equal (list (sym "FOO" "SYM") :external
)
204 (multiple-value-list (sym "FOO" "SYM"))))
205 (is (eq (sym "FOO" "SYM")
206 (sym "BAZ" "SYM"))))))
208 (with-test (:name
:export
.3.intern
)
209 (with-packages (("FOO" (:intern
"SYM"))
210 ("BAZ" (:use
"FOO") (:intern
"SYM")))
211 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
212 (export (sym "FOO" "SYM") "FOO")
214 (is (eq (sym "FOO" "SYM")
215 (sym "BAZ" "SYM"))))))
217 (with-test (:name
:export
.3a.intern
)
218 (with-packages (("FOO" (:intern
"SYM"))
219 ("BAZ" (:use
"FOO") (:intern
"SYM")))
220 (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp
)
221 (export (sym "FOO" "SYM") "FOO")
223 (is (equal (list (sym "BAZ" "SYM") :internal
)
224 (multiple-value-list (sym "BAZ" "SYM")))))))
227 (with-test (:name
:import-nil
.1)
228 (with-packages (("FOO" (:use
) (:intern
"NIL"))
229 ("BAZ" (:use
) (:intern
"NIL")))
230 (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp
)
231 (import (list (sym "FOO" "NIL")) "BAZ")
233 (is (eq (sym "FOO" "NIL")
234 (sym "BAZ" "NIL"))))))
236 (with-test (:name
:import-nil
.2)
237 (with-packages (("BAZ" (:use
) (:intern
"NIL")))
238 (with-name-conflict-resolution ('CL
:NIL
:restarted restartedp
)
239 (import '(CL:NIL
) "BAZ")
242 (sym "BAZ" "NIL"))))))
244 (with-test (:name
:import-single-conflict
:fails-on
:sbcl
)
245 (with-packages (("FOO" (:export
"NIL"))
246 ("BAR" (:export
"NIL"))
248 (let ((conflict-sets '()))
250 ((sb-ext:name-conflict
252 (push (copy-list (sb-ext:name-conflict-symbols condition
))
254 (invoke-restart 'sb-ext
:resolve-conflict
'CL
:NIL
))))
255 (import (list 'CL
:NIL
(sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ"))
256 (is (eql 1 (length conflict-sets
)))
257 (is (eql 3 (length (first conflict-sets
)))))))
259 ;;; Make sure that resolving a name-conflict in IMPORT doesn't leave
260 ;;; multiple symbols of the same name in the package (this particular
261 ;;; scenario found in 1.0.38.9, but clearly a longstanding issue).
262 (with-test (:name
:import-conflict-resolution
)
263 (with-packages (("FOO" (:export
"NIL"))
265 (with-name-conflict-resolution ((sym "FOO" "NIL"))
266 (import (list 'CL
:NIL
(sym "FOO" "NIL")) "BAR"))
267 (do-symbols (sym "BAR")
268 (assert (eq sym
(sym "FOO" "NIL"))))))
271 (with-test (:name
:unintern
.1)
272 (with-packages (("FOO" (:export
"SYM"))
273 ("BAR" (:export
"SYM"))
274 ("BAZ" (:use
"FOO" "BAR") (:shadow
"SYM")))
275 (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp
)
276 (unintern (sym "BAZ" "SYM") "BAZ")
278 (is (eq (sym "FOO" "SYM")
279 (sym "BAZ" "SYM"))))))
281 (with-test (:name
:unintern
.2)
282 (with-packages (("FOO" (:intern
"SYM")))
283 (unintern :sym
"FOO")
284 (assert (find-symbol "SYM" "FOO"))))
286 ;;; WITH-PACKAGE-ITERATOR error signalling had problems
287 (with-test (:name
:with-package-iterator.error
)
291 (eval '(with-package-iterator (sym :cl-user
:foo
)
294 ((and simple-condition program-error
) (c)
295 (assert (equal (list :foo
) (simple-condition-format-arguments c
)))
298 ;; X3J13 writeup HASH-TABLE-PACKAGE-GENERATORS says
299 ;; "An argument of NIL is treated as an empty list of packages."
300 ;; This used to fail with "NIL does not name a package"
301 (with-test (:name
:with-package-iterator-nil-list
)
302 (with-package-iterator (iter '() :internal
)
303 (print (nth-value 1 (iter)))))
305 ;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
306 (with-test (:name
:bug-511072
:skipped-on
'(not :sb-thread
))
307 (let* ((p (make-package :bug-511072
))
308 (sem1 (sb-thread:make-semaphore
))
309 (sem2 (sb-thread:make-semaphore
))
310 (t2 (make-join-thread (lambda ()
311 (handler-bind ((error (lambda (c)
312 (sb-thread:signal-semaphore sem1
)
313 (sb-thread:wait-on-semaphore sem2
)
315 (make-package :bug-511072
))))))
316 (sb-thread:wait-on-semaphore sem1
)
318 (assert (eq 'cons
(read-from-string "CL:CONS"))))
319 (sb-thread:signal-semaphore sem2
)))
321 (with-test (:name
:quick-name-conflict-resolution-import
)
325 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1")
326 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2"))
328 (handler-bind ((name-conflict (lambda (c)
329 (invoke-restart 'sb-impl
::dont-import-it
))))
330 (import (intern "FOO" p2
) p1
))
331 (assert (not (eq (intern "FOO" p1
) (intern "FOO" p2
))))
332 (handler-bind ((name-conflict (lambda (c)
333 (invoke-restart 'sb-impl
::shadowing-import-it
))))
334 (import (intern "FOO" p2
) p1
))
335 (assert (eq (intern "FOO" p1
) (intern "FOO" p2
))))
336 (when p1
(delete-package p1
))
337 (when p2
(delete-package p2
)))))
339 (with-test (:name
:quick-name-conflict-resolution-export
.1)
343 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a")
344 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a"))
347 (handler-bind ((name-conflict (lambda (c)
348 (invoke-restart 'sb-impl
::keep-old
))))
349 (export (intern "FOO" p2
) p2
))
350 (assert (not (eq (intern "FOO" p1
) (intern "FOO" p2
)))))
351 (when p1
(delete-package p1
))
352 (when p2
(delete-package p2
)))))
354 (with-test (:name
:quick-name-conflict-resolution-export
.2)
358 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b")
359 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b"))
362 (handler-bind ((name-conflict (lambda (c)
363 (invoke-restart 'sb-impl
::take-new
))))
364 (export (intern "FOO" p2
) p2
))
365 (assert (eq (intern "FOO" p1
) (intern "FOO" p2
))))
366 (when p1
(delete-package p1
))
367 (when p2
(delete-package p2
)))))
369 (with-test (:name
:quick-name-conflict-resolution-use-package
.1)
373 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a")
374 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a"))
377 (export (intern "FOO" p2
) p2
)
378 (export (intern "BAR" p2
) p2
)
379 (handler-bind ((name-conflict (lambda (c)
380 (invoke-restart 'sb-impl
::keep-old
))))
382 (assert (not (eq (intern "FOO" p1
) (intern "FOO" p2
))))
383 (assert (not (eq (intern "BAR" p1
) (intern "BAR" p2
)))))
384 (when p1
(delete-package p1
))
385 (when p2
(delete-package p2
)))))
387 (with-test (:name
:quick-name-conflict-resolution-use-package
.2)
391 (setf p1
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b")
392 p2
(make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b"))
395 (export (intern "FOO" p2
) p2
)
396 (export (intern "BAR" p2
) p2
)
397 (handler-bind ((name-conflict (lambda (c)
398 (invoke-restart 'sb-impl
::take-new
))))
400 (assert (eq (intern "FOO" p1
) (intern "FOO" p2
)))
401 (assert (eq (intern "BAR" p1
) (intern "BAR" p2
))))
402 (when p1
(delete-package p1
))
403 (when p2
(delete-package p2
)))))
405 (with-test (:name
(:package-at-variance-restarts
:shadow
))
407 (*on-package-variance
* '(:error t
)))
410 (setf p
(eval `(defpackage :package-at-variance-restarts
.1
413 (handler-bind ((sb-kernel::package-at-variance-error
415 (invoke-restart 'sb-impl
::keep-them
))))
416 (eval `(defpackage :package-at-variance-restarts
.1
418 (assert (not (eq 'cl
:cons
(intern "CONS" p
))))
419 (handler-bind ((sb-kernel::package-at-variance-error
421 (invoke-restart 'sb-impl
::drop-them
))))
422 (eval `(defpackage :package-at-variance-restarts
.1
424 (assert (eq 'cl
:cons
(intern "CONS" p
))))
425 (when p
(delete-package p
)))))
427 (with-test (:name
(:package-at-variance-restarts
:use
))
429 (*on-package-variance
* '(:error t
)))
432 (setf p
(eval `(defpackage :package-at-variance-restarts
.2
434 (handler-bind ((sb-kernel::package-at-variance-error
436 (invoke-restart 'sb-impl
::keep-them
))))
437 (eval `(defpackage :package-at-variance-restarts
.2
439 (assert (eq 'cl
:cons
(intern "CONS" p
)))
440 (handler-bind ((sb-kernel::package-at-variance-error
442 (invoke-restart 'sb-impl
::drop-them
))))
443 (eval `(defpackage :package-at-variance-restarts
.2
445 (assert (not (eq 'cl
:cons
(intern "CONS" p
)))))
446 (when p
(delete-package p
)))))
448 (with-test (:name
(:package-at-variance-restarts
:export
))
450 (*on-package-variance
* '(:error t
)))
453 (setf p
(eval `(defpackage :package-at-variance-restarts
.4
455 (handler-bind ((sb-kernel::package-at-variance-error
457 (invoke-restart 'sb-impl
::keep-them
))))
458 (eval `(defpackage :package-at-variance-restarts
.4)))
459 (assert (eq :external
(nth-value 1 (find-symbol "FOO" p
))))
460 (handler-bind ((sb-kernel::package-at-variance-error
462 (invoke-restart 'sb-impl
::drop-them
))))
463 (eval `(defpackage :package-at-variance-restarts
.4)))
464 (assert (eq :internal
(nth-value 1 (find-symbol "FOO" p
)))))
465 (when p
(delete-package p
)))))
467 (with-test (:name
(:package-at-variance-restarts
:implement
))
469 (*on-package-variance
* '(:error t
)))
472 (setf p
(eval `(defpackage :package-at-variance-restarts
.5
473 (:implement
:sb-int
))))
474 (handler-bind ((sb-kernel::package-at-variance-error
476 (invoke-restart 'sb-impl
::keep-them
))))
477 (eval `(defpackage :package-at-variance-restarts
.5)))
478 (assert (member p
(package-implemented-by-list :sb-int
)))
479 (handler-bind ((sb-kernel::package-at-variance-error
481 (invoke-restart 'sb-impl
::drop-them
))))
482 (eval `(defpackage :package-at-variance-restarts
.5)))
483 (assert (not (member p
(package-implemented-by-list :sb-int
)))))
484 (when p
(delete-package p
)))))
486 (with-test (:name
(:delete-package
:implementation-package
))
490 (setf p1
(make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1")
491 p2
(make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2"))
492 (add-implementation-package p2 p1
)
493 (assert (= 1 (length (package-implemented-by-list p1
))))
495 (assert (= 0 (length (package-implemented-by-list p1
)))))
496 (when p1
(delete-package p1
))
497 (when p2
(delete-package p2
)))))
499 (with-test (:name
(:delete-package
:implementated-package
))
503 (setf p1
(make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1")
504 p2
(make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2"))
505 (add-implementation-package p2 p1
)
506 (assert (= 1 (length (package-implements-list p2
))))
508 (assert (= 0 (length (package-implements-list p2
)))))
509 (when p1
(delete-package p1
))
510 (when p2
(delete-package p2
)))))
512 (with-test (:name
:package-local-nicknames
)
514 (without-package-locks
515 (when (find-package :package-local-nicknames-test-1
)
516 (delete-package :package-local-nicknames-test-1
))
517 (when (find-package :package-local-nicknames-test-2
)
518 (delete-package :package-local-nicknames-test-2
)))
519 (eval `(defpackage :package-local-nicknames-test-1
520 (:local-nicknames
(:l
:cl
) (:sb
:sb-ext
))))
521 (eval `(defpackage :package-local-nicknames-test-2
524 (let ((alist (package-local-nicknames :package-local-nicknames-test-1
)))
525 (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist
:test
'string
=)))
526 (assert (equal (cons "SB" (find-package "SB-EXT")) (assoc "SB" alist
:test
'string
=)))
527 (assert (eql 2 (length alist
))))
529 (let ((*package
* (find-package :package-local-nicknames-test-1
)))
530 (let ((cons0 (read-from-string "L:CONS"))
531 (exit0 (read-from-string "SB:EXIT"))
532 (cons1 (find-symbol "CONS" :l
))
533 (exit1 (find-symbol "EXIT" :sb
))
534 (cl (find-package :l
))
535 (sb (find-package :sb
)))
536 (assert (eq 'cons cons0
))
537 (assert (eq 'cons cons1
))
538 (assert (equal "L:CONS" (prin1-to-string cons0
)))
539 (assert (eq 'sb-ext
:exit exit0
))
540 (assert (eq 'sb-ext
:exit exit1
))
541 (assert (equal "SB:EXIT" (prin1-to-string exit0
)))
542 (assert (eq cl
(find-package :common-lisp
)))
543 (assert (eq sb
(find-package :sb-ext
)))))
544 ;; Can't add same name twice for different global names.
547 (add-package-local-nickname :l
:package-local-nicknames-test-2
548 :package-local-nicknames-test-1
)
551 ;; But same name twice is OK.
552 (add-package-local-nickname :l
:cl
:package-local-nicknames-test-1
)
554 (assert (remove-package-local-nickname :l
:package-local-nicknames-test-1
))
555 (let ((*package
* (find-package :package-local-nicknames-test-1
)))
556 (let ((exit0 (read-from-string "SB:EXIT"))
557 (exit1 (find-symbol "EXIT" :sb
))
558 (sb (find-package :sb
)))
559 (assert (eq 'sb-ext
:exit exit0
))
560 (assert (eq 'sb-ext
:exit exit1
))
561 (assert (equal "SB:EXIT" (prin1-to-string exit0
)))
562 (assert (eq sb
(find-package :sb-ext
)))
563 (assert (not (find-package :l
)))))
564 ;; Adding back as another package.
565 (assert (eq (find-package :package-local-nicknames-test-1
)
566 (add-package-local-nickname :l
:package-local-nicknames-test-2
567 :package-local-nicknames-test-1
)))
568 (let ((*package
* (find-package :package-local-nicknames-test-1
)))
569 (let ((cons0 (read-from-string "L:CONS"))
570 (exit0 (read-from-string "SB:EXIT"))
571 (cons1 (find-symbol "CONS" :l
))
572 (exit1 (find-symbol "EXIT" :sb
))
573 (cl (find-package :l
))
574 (sb (find-package :sb
)))
575 (assert (eq cons0 cons1
))
576 (assert (not (eq 'cons cons0
)))
577 (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2
)
579 (assert (equal "L:CONS" (prin1-to-string cons0
)))
580 (assert (eq 'sb-ext
:exit exit0
))
581 (assert (eq 'sb-ext
:exit exit1
))
582 (assert (equal "SB:EXIT" (prin1-to-string exit0
)))
583 (assert (eq cl
(find-package :package-local-nicknames-test-2
)))
584 (assert (eq sb
(find-package :sb-ext
)))))
585 ;; Interaction with package locks.
586 (lock-package :package-local-nicknames-test-1
)
587 (assert (eq :package-oopsie
589 (add-package-local-nickname :c
:sb-c
:package-local-nicknames-test-1
)
590 (package-lock-violation ()
592 (assert (eq :package-oopsie
594 (remove-package-local-nickname :l
:package-local-nicknames-test-1
)
595 (package-lock-violation ()
597 (unlock-package :package-local-nicknames-test-1
)
598 (add-package-local-nickname :c
:sb-c
:package-local-nicknames-test-1
)
599 (remove-package-local-nickname :l
:package-local-nicknames-test-1
))
601 (defmacro with-tmp-packages
(bindings &body body
)
602 `(let ,(mapcar #'car bindings
)
605 (setf ,@(apply #'append bindings
))
607 ,@(mapcar (lambda (p)
608 `(when ,p
(delete-package ,p
)))
609 (mapcar #'car bindings
)))))
611 (with-test (:name
(:delete-package
:locally-nicknames-others
))
612 (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
613 (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
614 (add-package-local-nickname :foo p2 p1
)
615 (assert (equal (list p1
) (package-locally-nicknamed-by-list p2
)))
617 (assert (not (package-locally-nicknamed-by-list p2
)))))
619 (with-test (:name
(:delete-package
:locally-nicknamed-by-others
))
620 (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
621 (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
622 (add-package-local-nickname :foo p2 p1
)
623 (assert (package-local-nicknames p1
))
625 (assert (not (package-local-nicknames p1
)))))
627 (with-test (:name
:own-name-as-local-nickname
)
628 (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
629 (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
632 (add-package-local-nickname :own-name-as-nickname1 p2 p1
)
635 (handler-bind ((error #'continue
))
636 (add-package-local-nickname :own-name-as-nickname1 p2 p1
))
637 (assert (eq (intern "FOO" p2
)
638 (let ((*package
* p1
))
639 (intern "FOO" :own-name-as-nickname1
))))))
641 (with-test (:name
:own-nickname-as-local-nickname
)
642 (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
643 :nicknames
'("OWN-NICKNAME")))
644 (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
647 (add-package-local-nickname :own-nickname p2 p1
)
650 (handler-bind ((error #'continue
))
651 (add-package-local-nickname :own-nickname p2 p1
))
652 (assert (eq (intern "FOO" p2
)
653 (let ((*package
* p1
))
654 (intern "FOO" :own-nickname
))))))
656 (with-test (:name
:delete-package-restart
)
660 ((sb-kernel:simple-package-error
664 (delete-package (gensym)))))
666 (assert (not result
))))
668 ;; WITH-PACKAGE-ITERATOR isn't well-exercised by tests (though LOOP uses it)
669 ;; so here's a basic correctness test with some complications involving
670 ;; shadowing symbols.
671 (make-package "P1" :use
'("SB-FORMAT"))
673 (export 'p1
::foo
'p1
)
674 (shadow "FORMAT-ERROR" 'p1
)
675 (make-package "A" :use
'("SB-FORMAT" "P1" "P2"))
676 (shadow '("PROG2" "FOO") 'a
)
678 (export 'p2
::(foo bar baz
) 'p2
)
679 (export 'a
::goodfun
'a
)
681 (with-test (:name
:with-package-iterator
)
682 (let ((tests '((:internal
) (:external
) (:inherited
)
683 (:internal
:inherited
)
684 (:internal
:external
)
685 (:external
:inherited
)
686 (:internal
:external
:inherited
)))
688 '(;; symbols visible in A
689 (a::prog2
:internal
"A")
690 (a::foo
:internal
"A")
691 (a:goodfun
:external
"A")
692 (p2:bar
:inherited
"A")
693 (p2:baz
:inherited
"A")
694 (sb-format:%compiler-walk-format-string
:inherited
"A")
695 (sb-format:format-error
:inherited
"A")
697 (p1:foo
:external
"P1")
698 (p1::format-error
:internal
"P1")
699 (sb-format:%compiler-walk-format-string
:inherited
"P1")
701 (p2::blah
:internal
"P2")
702 (p2:foo
:external
"P2")
703 (p2:bar
:external
"P2")
704 (p2:baz
:external
"P2"))))
705 ;; Compile a new function to test each combination of
706 ;; accessibility-kind since the macro doesn't eval them.
707 (dolist (access tests
)
708 ; (print `(testing ,access))
712 (with-package-iterator (iter '(p1 a p2
) ,@access
)
715 (multiple-value-bind (foundp sym access pkg
) (iter)
717 (push (list sym access
(package-name pkg
)) res
)
720 (let ((answer (funcall f
))
721 (expect (remove-if-not (lambda (x) (member (second x
) access
))
723 ;; exactly as many results as expected
724 (assert (equal (length answer
) (length expect
)))
725 ;; each result is right
726 (assert (equal (length (intersection answer expect
:test
#'equal
))
727 (length expect
))))))))
729 ;; Assert that changes in size of a package-hashtable's symbol vector
730 ;; do not cause WITH-PACKAGE-ITERATOR to crash. The vector shouldn't grow,
731 ;; because it is not permitted to INTERN new symbols, but it can shrink
732 ;; because it is expressly permitted to UNINTERN the current symbol.
733 ;; (In fact we allow INTERN, but that's beside the point)
734 (with-test (:name
:with-package-iterator-and-mutation
)
735 (flet ((table-size (pkg)
736 (length (sb-impl::package-hashtable-cells
737 (sb-impl::package-internal-symbols pkg
)))))
738 (let* ((p (make-package (string (gensym))))
739 (initial-table-size (table-size p
))
741 '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m")))
744 (let ((grown-table-size (table-size p
)))
745 (assert (> grown-table-size initial-table-size
))
747 (with-package-iterator (iter p
:internal
)
748 (loop (multiple-value-bind (foundp sym
) (iter)
754 (assert (= n
(length strings
)))
755 ;; while we're at it, assert that calling the iterator
756 ;; a couple more times returns nothing.
758 (assert (not (iter))))))
759 (let ((shrunk-table-size (table-size p
)))
760 (assert (< shrunk-table-size grown-table-size
)))))))
763 (with-test (:name
:do-symbols-block-scope
)
766 (do-symbols (s (or (find-package "FROB") (return nil
)))
770 (with-test (:name
:export-inaccessible-lookalike
)
773 (export (intern "A" "E2") 'e2
)
774 (multiple-value-bind (answer condition
)
775 (ignore-errors (export (intern "A" "E1") 'e2
))
776 (assert (and (not answer
)
777 (and (typep condition
'sb-kernel
:simple-package-error
)
778 (search "not accessible"
779 (simple-condition-format-control condition
)))))))
781 ;; Concurrent FIND-SYMBOL was adversely affected by package rehash.
782 ;; It's slightly difficult to show that this is fixed, because this
783 ;; test only sometimes failed prior to the fix. Now it never fails though.
784 (with-test (:name
:concurrent-find-symbol
:skipped-on
'(not :sb-thread
))
785 (let ((pkg (make-package (gensym)))
790 (let ((s (string (gensym "FRED"))))
794 (push (sb-thread:make-thread
798 (dotimes (i 10 n-missing
)
800 (unless (find-symbol name pkg
)
801 (incf n-missing
)))))))
804 ;; Interning new symbols can't cause the pre-determined
805 ;; 50 names to transiently disappear.
806 (let ((s (make-string 3))
807 (alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZ012345"))
808 (dotimes (i (expt 32 3))
809 (setf (char s
0) (char alphabet
(ldb (byte 5 10) i
))
810 (char s
1) (char alphabet
(ldb (byte 5 5) i
))
811 (char s
2) (char alphabet
(ldb (byte 5 0) i
)))
813 (let ((tot-missing 0))
814 (dolist (thread threads
(assert (zerop tot-missing
)))
815 (incf tot-missing
(sb-thread:join-thread thread
))))))