Clean up listify-rest-args VOP on x86-64.
[sbcl.git] / tests / packages.impure.lisp
1 ;;;; miscellaneous tests of package-related stuff
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
14 (make-package "FOO")
15 (defvar *foo* (find-package (coerce "FOO" 'base-string)))
16 (rename-package "FOO" (make-array 0 :element-type nil))
17 (assert (eq *foo* (find-package "")))
18 (assert (delete-package ""))
19
20 (make-package "BAR")
21 (defvar *baz* (rename-package "BAR" "BAZ"))
22 (assert (eq *baz* (find-package "BAZ")))
23 (assert (delete-package *baz*))
24
25 (handler-case
26     (export :foo)
27   (package-error (c) (princ c))
28   (:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args)))
29
30 (make-package "FOO")
31 (assert (shadow #\a :foo))
32
33 (defpackage :PACKAGE-DESIGNATOR-1 (:use #.(find-package :cl)))
34
35 (defpackage :PACKAGE-DESIGNATOR-2
36   (:import-from #.(find-package :cl) "+"))
37
38 (defpackage "EXAMPLE-INDIRECT"
39   (:import-from "CL" "+"))
40
41 (defpackage "EXAMPLE-PACKAGE"
42   (:shadow "CAR")
43   (:shadowing-import-from "CL" "CAAR")
44   (:use)
45   (:import-from "CL" "CDR")
46   (:import-from "EXAMPLE-INDIRECT" "+")
47   (:export "CAR" "CDR" "EXAMPLE"))
48
49 (flet ((check-symbol (name expected-status expected-home-name)
50          (multiple-value-bind (symbol status)
51              (find-symbol name "EXAMPLE-PACKAGE")
52            (let ((home (symbol-package symbol))
53                  (expected-home (find-package expected-home-name)))
54              (assert (eql home expected-home))
55              (assert (eql status expected-status))))))
56   (check-symbol "CAR" :external "EXAMPLE-PACKAGE")
57   (check-symbol "CDR" :external "CL")
58   (check-symbol "EXAMPLE" :external "EXAMPLE-PACKAGE")
59   (check-symbol "CAAR" :internal "CL")
60   (check-symbol "+" :internal "CL")
61   (check-symbol "CDDR" nil "CL"))
62
63 (defpackage "TEST-ORIGINAL" (:nicknames "A-NICKNAME"))
64
65 (assert (raises-error? (defpackage "A-NICKNAME")))
66
67 (assert (eql (find-package "A-NICKNAME")
68              (find-package "TEST-ORIGINAL")))
69
70 ;;;; Utilities
71 (defun sym (package name)
72  (let ((package (or (find-package package) package)))
73    (multiple-value-bind (symbol status)
74        (find-symbol name package)
75      (assert status
76              (package name symbol status)
77              "No symbol with name ~A in ~S." name package symbol status)
78    (values symbol status))))
79
80 (defmacro with-name-conflict-resolution ((symbol &key restarted)
81                                          form &body body)
82   "Resolves potential name conflict condition arising from FORM.
83
84 The conflict is resolved in favour of SYMBOL, a form which must
85 evaluate to a symbol.
86
87 If RESTARTED is a symbol, it is bound for the BODY forms and set to T
88 if a restart was invoked."
89   (check-type restarted symbol "a binding name")
90   (let ((%symbol (copy-symbol 'symbol)))
91     `(let (,@(when restarted `((,restarted)))
92            (,%symbol ,symbol))
93        (handler-bind
94            ((sb-ext:name-conflict
95              (lambda (condition)
96                ,@(when restarted `((setf ,restarted t)))
97                (assert (member ,%symbol (sb-ext:name-conflict-symbols condition)))
98                (invoke-restart 'sb-ext:resolve-conflict ,%symbol))))
99          ,form)
100        ,@body)))
101
102 (defmacro with-packages (specs &body forms)
103   (let ((names (mapcar #'car specs)))
104     `(unwind-protect
105           (progn
106             (delete-packages ',names)
107             ,@(mapcar (lambda (spec)
108                         `(defpackage ,@spec))
109                       specs)
110             ,@forms)
111        (delete-packages ',names))))
112
113 (defun delete-packages (names)
114   (dolist (p names)
115     (ignore-errors (delete-package p))))
116
117
118 ;;;; Tests
119 ;;; USE-PACKAGE
120 (with-test (:name use-package.1)
121   (with-packages (("FOO" (:export "SYM"))
122                   ("BAR" (:export "SYM"))
123                   ("BAZ" (:use)))
124     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
125         (use-package '("FOO" "BAR") "BAZ")
126       (is restartedp)
127       (is (eq (sym "BAR" "SYM")
128               (sym "BAZ" "SYM"))))))
129
130 (with-test (:name use-package.2)
131   (with-packages (("FOO" (:export "SYM"))
132                   ("BAZ" (:use) (:intern "SYM")))
133     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
134         (use-package "FOO" "BAZ")
135       (is restartedp)
136       (is (eq (sym "FOO" "SYM")
137               (sym "BAZ" "SYM"))))))
138
139 (with-test (:name use-package.2a)
140   (with-packages (("FOO" (:export "SYM"))
141                   ("BAZ" (:use) (:intern "SYM")))
142     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
143         (use-package "FOO" "BAZ")
144       (is restartedp)
145       (is (equal (list (sym "BAZ" "SYM") :internal)
146                  (multiple-value-list (sym "BAZ" "SYM")))))))
147
148 (with-test (:name use-package-conflict-set :fails-on :sbcl)
149   (with-packages (("FOO" (:export "SYM"))
150                   ("QUX" (:export "SYM"))
151                   ("BAR" (:intern "SYM"))
152                   ("BAZ" (:use) (:import-from "BAR" "SYM")))
153     (let ((conflict-set))
154       (block nil
155         (handler-bind
156             ((sb-ext:name-conflict
157               (lambda (condition)
158                 (setf conflict-set (copy-list
159                                     (sb-ext:name-conflict-symbols condition)))
160                 (return))))
161           (use-package '("FOO" "QUX") "BAZ")))
162       (setf conflict-set
163             (sort conflict-set #'string<
164                   :key (lambda (symbol)
165                          (package-name (symbol-package symbol)))))
166       (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM"))
167                  conflict-set)))))
168
169 ;;; EXPORT
170 (with-test (:name export.1)
171   (with-packages (("FOO" (:intern "SYM"))
172                   ("BAR" (:export "SYM"))
173                   ("BAZ" (:use "FOO" "BAR")))
174     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
175         (export (sym "FOO" "SYM") "FOO")
176       (is restartedp)
177       (is (eq (sym "FOO" "SYM")
178               (sym "BAZ" "SYM"))))))
179
180 (with-test (:name export.1a)
181   (with-packages (("FOO" (:intern "SYM"))
182                   ("BAR" (:export "SYM"))
183                   ("BAZ" (:use "FOO" "BAR")))
184     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
185         (export (sym "FOO" "SYM") "FOO")
186       (is restartedp)
187       (is (eq (sym "BAR" "SYM")
188               (sym "BAZ" "SYM"))))))
189
190 (with-test (:name export.ensure-exported)
191   (with-packages (("FOO" (:intern "SYM"))
192                   ("BAR" (:export "SYM"))
193                   ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM")))
194     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
195         (export (sym "FOO" "SYM") "FOO")
196       (is restartedp)
197       (is (equal (list (sym "FOO" "SYM") :external)
198                  (multiple-value-list (sym "FOO" "SYM"))))
199       (is (eq (sym "FOO" "SYM")
200               (sym "BAZ" "SYM"))))))
201
202 (with-test (:name export.3.intern)
203   (with-packages (("FOO" (:intern "SYM"))
204                   ("BAZ" (:use "FOO") (:intern "SYM")))
205     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
206         (export (sym "FOO" "SYM") "FOO")
207       (is restartedp)
208       (is (eq (sym "FOO" "SYM")
209               (sym "BAZ" "SYM"))))))
210
211 (with-test (:name export.3a.intern)
212   (with-packages (("FOO" (:intern "SYM"))
213                   ("BAZ" (:use "FOO") (:intern "SYM")))
214     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
215         (export (sym "FOO" "SYM") "FOO")
216       (is restartedp)
217       (is (equal (list (sym "BAZ" "SYM") :internal)
218                  (multiple-value-list (sym "BAZ" "SYM")))))))
219
220 ;;; IMPORT
221 (with-test (:name import-nil.1)
222   (with-packages (("FOO" (:use) (:intern "NIL"))
223                   ("BAZ" (:use) (:intern "NIL")))
224     (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp)
225         (import (list (sym "FOO" "NIL")) "BAZ")
226       (is restartedp)
227       (is (eq (sym "FOO" "NIL")
228               (sym "BAZ" "NIL"))))))
229
230 (with-test (:name import-nil.2)
231   (with-packages (("BAZ" (:use) (:intern "NIL")))
232     (with-name-conflict-resolution ('CL:NIL :restarted restartedp)
233         (import '(CL:NIL) "BAZ")
234       (is restartedp)
235       (is (eq 'CL:NIL
236               (sym "BAZ" "NIL"))))))
237
238 (with-test (:name import-single-conflict :fails-on :sbcl)
239   (with-packages (("FOO" (:export "NIL"))
240                   ("BAR" (:export "NIL"))
241                   ("BAZ" (:use)))
242     (let ((conflict-sets '()))
243       (handler-bind
244           ((sb-ext:name-conflict
245             (lambda (condition)
246               (push (copy-list (sb-ext:name-conflict-symbols condition))
247                     conflict-sets)
248               (invoke-restart 'sb-ext:resolve-conflict 'CL:NIL))))
249         (import (list 'CL:NIL (sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ"))
250       (is (eql 1 (length conflict-sets)))
251       (is (eql 3 (length (first conflict-sets)))))))
252
253 ;;; Make sure that resolving a name-conflict in IMPORT doesn't leave
254 ;;; multiple symbols of the same name in the package (this particular
255 ;;; scenario found in 1.0.38.9, but clearly a longstanding issue).
256 (with-test (:name import-conflict-resolution)
257   (with-packages (("FOO" (:export "NIL"))
258                   ("BAR" (:use)))
259     (with-name-conflict-resolution ((sym "FOO" "NIL"))
260       (import (list 'CL:NIL (sym "FOO" "NIL")) "BAR"))
261     (do-symbols (sym "BAR")
262       (assert (eq sym (sym "FOO" "NIL"))))))
263
264 ;;; UNINTERN
265 (with-test (:name unintern.1)
266   (with-packages (("FOO" (:export "SYM"))
267                   ("BAR" (:export "SYM"))
268                   ("BAZ" (:use "FOO" "BAR") (:shadow "SYM")))
269     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
270         (unintern (sym "BAZ" "SYM") "BAZ")
271       (is restartedp)
272       (is (eq (sym "FOO" "SYM")
273               (sym "BAZ" "SYM"))))))
274
275 (with-test (:name unintern.2)
276   (with-packages (("FOO" (:intern "SYM")))
277     (unintern :sym "FOO")
278     (assert (find-symbol "SYM" "FOO"))))
279
280 ;;; WITH-PACKAGE-ITERATOR error signalling had problems
281 (with-test (:name with-package-itarator.error)
282   (assert (eq :good
283               (handler-case
284                   (progn
285                     (eval '(with-package-iterator (sym :cl-user :foo)
286                             (sym)))
287                     :bad)
288                 ((and simple-condition program-error) (c)
289                   (assert (equal (list :foo) (simple-condition-format-arguments c)))
290                   :good)))))
291
292 ;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
293 (with-test (:name :bug-511072 :skipped-on '(not :sb-thread))
294   (let* ((p (make-package :bug-511072))
295          (sem1 (sb-thread:make-semaphore))
296          (sem2 (sb-thread:make-semaphore))
297          (t2 (make-join-thread (lambda ()
298                                  (handler-bind ((error (lambda (c)
299                                                          (sb-thread:signal-semaphore sem1)
300                                                          (sb-thread:wait-on-semaphore sem2)
301                                                          (abort c))))
302                                    (make-package :bug-511072))))))
303     (sb-thread:wait-on-semaphore sem1)
304     (with-timeout 10
305       (assert (eq 'cons (read-from-string "CL:CONS"))))
306     (sb-thread:signal-semaphore sem2)))
307
308 (with-test (:name :quick-name-conflict-resolution-import)
309   (let (p1 p2)
310     (unwind-protect
311          (progn
312            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1")
313                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2"))
314            (intern "FOO" p1)
315            (handler-bind ((name-conflict (lambda (c)
316                                            (invoke-restart 'sb-impl::dont-import-it))))
317              (import (intern "FOO" p2) p1))
318            (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
319            (handler-bind ((name-conflict (lambda (c)
320                                            (invoke-restart 'sb-impl::shadowing-import-it))))
321              (import (intern "FOO" p2) p1))
322            (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
323       (when p1 (delete-package p1))
324       (when p2 (delete-package p2)))))
325
326 (with-test (:name :quick-name-conflict-resolution-export.1)
327   (let (p1 p2)
328     (unwind-protect
329          (progn
330            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a")
331                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a"))
332            (intern "FOO" p1)
333            (use-package p2 p1)
334            (handler-bind ((name-conflict (lambda (c)
335                                            (invoke-restart 'sb-impl::keep-old))))
336              (export (intern "FOO" p2) p2))
337            (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))))
338       (when p1 (delete-package p1))
339       (when p2 (delete-package p2)))))
340
341 (with-test (:name :quick-name-conflict-resolution-export.2)
342   (let (p1 p2)
343     (unwind-protect
344          (progn
345            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b")
346                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b"))
347            (intern "FOO" p1)
348            (use-package p2 p1)
349            (handler-bind ((name-conflict (lambda (c)
350                                            (invoke-restart 'sb-impl::take-new))))
351              (export (intern "FOO" p2) p2))
352            (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
353       (when p1 (delete-package p1))
354       (when p2 (delete-package p2)))))
355
356 (with-test (:name :quick-name-conflict-resolution-use-package.1)
357   (let (p1 p2)
358     (unwind-protect
359          (progn
360            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a")
361                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a"))
362            (intern "FOO" p1)
363            (intern "BAR" p1)
364            (export (intern "FOO" p2) p2)
365            (export (intern "BAR" p2) p2)
366            (handler-bind ((name-conflict (lambda (c)
367                                            (invoke-restart 'sb-impl::keep-old))))
368              (use-package p2 p1))
369            (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
370            (assert (not (eq (intern "BAR" p1) (intern "BAR" p2)))))
371       (when p1 (delete-package p1))
372       (when p2 (delete-package p2)))))
373
374 (with-test (:name :quick-name-conflict-resolution-use-package.2)
375   (let (p1 p2)
376     (unwind-protect
377          (progn
378            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b")
379                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b"))
380            (intern "FOO" p1)
381            (intern "BAR" p1)
382            (export (intern "FOO" p2) p2)
383            (export (intern "BAR" p2) p2)
384            (handler-bind ((name-conflict (lambda (c)
385                                            (invoke-restart 'sb-impl::take-new))))
386              (use-package p2 p1))
387            (assert (eq (intern "FOO" p1) (intern "FOO" p2)))
388            (assert (eq (intern "BAR" p1) (intern "BAR" p2))))
389       (when p1 (delete-package p1))
390       (when p2 (delete-package p2)))))
391
392 (with-test (:name (:package-at-variance-restarts :shadow))
393   (let ((p nil)
394         (*on-package-variance* '(:error t)))
395     (unwind-protect
396          (progn
397            (setf p (eval `(defpackage :package-at-variance-restarts.1
398                             (:use :cl)
399                             (:shadow "CONS"))))
400            (handler-bind ((sb-kernel::package-at-variance-error
401                             (lambda (c)
402                               (invoke-restart 'sb-impl::keep-them))))
403              (eval `(defpackage :package-at-variance-restarts.1
404                       (:use :cl))))
405            (assert (not (eq 'cl:cons (intern "CONS" p))))
406            (handler-bind ((sb-kernel::package-at-variance-error
407                             (lambda (c)
408                               (invoke-restart 'sb-impl::drop-them))))
409              (eval `(defpackage :package-at-variance-restarts.1
410                       (:use :cl))))
411            (assert (eq 'cl:cons (intern "CONS" p))))
412       (when p (delete-package p)))))
413
414 (with-test (:name (:package-at-variance-restarts :use))
415   (let ((p nil)
416         (*on-package-variance* '(:error t)))
417     (unwind-protect
418          (progn
419            (setf p (eval `(defpackage :package-at-variance-restarts.2
420                             (:use :cl))))
421            (handler-bind ((sb-kernel::package-at-variance-error
422                             (lambda (c)
423                               (invoke-restart 'sb-impl::keep-them))))
424              (eval `(defpackage :package-at-variance-restarts.2
425                       (:use))))
426            (assert (eq 'cl:cons (intern "CONS" p)))
427            (handler-bind ((sb-kernel::package-at-variance-error
428                             (lambda (c)
429                               (invoke-restart 'sb-impl::drop-them))))
430              (eval `(defpackage :package-at-variance-restarts.2
431                       (:use))))
432            (assert (not (eq 'cl:cons (intern "CONS" p)))))
433       (when p (delete-package p)))))
434
435 (with-test (:name (:package-at-variance-restarts :export))
436   (let ((p nil)
437         (*on-package-variance* '(:error t)))
438     (unwind-protect
439          (progn
440            (setf p (eval `(defpackage :package-at-variance-restarts.4
441                             (:export "FOO"))))
442            (handler-bind ((sb-kernel::package-at-variance-error
443                             (lambda (c)
444                               (invoke-restart 'sb-impl::keep-them))))
445              (eval `(defpackage :package-at-variance-restarts.4)))
446            (assert (eq :external (nth-value 1 (find-symbol "FOO" p))))
447            (handler-bind ((sb-kernel::package-at-variance-error
448                             (lambda (c)
449                               (invoke-restart 'sb-impl::drop-them))))
450              (eval `(defpackage :package-at-variance-restarts.4)))
451            (assert (eq :internal (nth-value 1 (find-symbol "FOO" p)))))
452       (when p (delete-package p)))))
453
454 (with-test (:name (:package-at-variance-restarts :implement))
455   (let ((p nil)
456         (*on-package-variance* '(:error t)))
457     (unwind-protect
458          (progn
459            (setf p (eval `(defpackage :package-at-variance-restarts.5
460                             (:implement :sb-int))))
461            (handler-bind ((sb-kernel::package-at-variance-error
462                             (lambda (c)
463                               (invoke-restart 'sb-impl::keep-them))))
464              (eval `(defpackage :package-at-variance-restarts.5)))
465            (assert (member p (package-implemented-by-list :sb-int)))
466            (handler-bind ((sb-kernel::package-at-variance-error
467                             (lambda (c)
468                               (invoke-restart 'sb-impl::drop-them))))
469              (eval `(defpackage :package-at-variance-restarts.5)))
470            (assert (not (member p (package-implemented-by-list :sb-int)))))
471       (when p (delete-package p)))))
472
473 (with-test (:name (:delete-package :implementation-package))
474   (let (p1 p2)
475     (unwind-protect
476          (progn
477            (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1")
478                  p2 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2"))
479            (add-implementation-package p2 p1)
480            (assert (= 1 (length (package-implemented-by-list p1))))
481            (delete-package p2)
482            (assert (= 0 (length (package-implemented-by-list p1)))))
483       (when p1 (delete-package p1))
484       (when p2 (delete-package p2)))))
485
486 (with-test (:name (:delete-package :implementated-package))
487   (let (p1 p2)
488     (unwind-protect
489          (progn
490            (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1")
491                  p2 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2"))
492            (add-implementation-package p2 p1)
493            (assert (= 1 (length (package-implements-list p2))))
494            (delete-package p1)
495            (assert (= 0 (length (package-implements-list p2)))))
496       (when p1 (delete-package p1))
497       (when p2 (delete-package p2)))))
498
499 (with-test (:name :package-local-nicknames)
500   ;; Clear slate
501   (without-package-locks
502     (when (find-package :package-local-nicknames-test-1)
503       (delete-package :package-local-nicknames-test-1))
504     (when (find-package :package-local-nicknames-test-2)
505       (delete-package :package-local-nicknames-test-2)))
506   (eval `(defpackage :package-local-nicknames-test-1
507            (:local-nicknames (:l :cl) (:sb :sb-ext))))
508   (eval `(defpackage :package-local-nicknames-test-2
509            (:export "CONS")))
510   ;; Introspection
511   (let ((alist (package-local-nicknames :package-local-nicknames-test-1)))
512     (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=)))
513     (assert (equal (cons "SB" (find-package "SB-EXT")) (assoc "SB" alist :test 'string=)))
514     (assert (eql 2 (length alist))))
515   ;; Usage
516   (let ((*package* (find-package :package-local-nicknames-test-1)))
517     (let ((cons0 (read-from-string "L:CONS"))
518           (exit0 (read-from-string "SB:EXIT"))
519           (cons1 (find-symbol "CONS" :l))
520           (exit1 (find-symbol "EXIT" :sb))
521           (cl (find-package :l))
522           (sb (find-package :sb)))
523       (assert (eq 'cons cons0))
524       (assert (eq 'cons cons1))
525       (assert (equal "L:CONS" (prin1-to-string cons0)))
526       (assert (eq 'sb-ext:exit exit0))
527       (assert (eq 'sb-ext:exit exit1))
528       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
529       (assert (eq cl (find-package :common-lisp)))
530       (assert (eq sb (find-package :sb-ext)))))
531   ;; Can't add same name twice for different global names.
532   (assert (eq :oopsie
533               (handler-case
534                   (add-package-local-nickname :l :package-local-nicknames-test-2
535                                               :package-local-nicknames-test-1)
536                 (error ()
537                   :oopsie))))
538   ;; But same name twice is OK.
539   (add-package-local-nickname :l :cl :package-local-nicknames-test-1)
540   ;; Removal.
541   (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
542   (let ((*package* (find-package :package-local-nicknames-test-1)))
543     (let ((exit0 (read-from-string "SB:EXIT"))
544           (exit1 (find-symbol "EXIT" :sb))
545           (sb (find-package :sb)))
546       (assert (eq 'sb-ext:exit exit0))
547       (assert (eq 'sb-ext:exit exit1))
548       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
549       (assert (eq sb (find-package :sb-ext)))
550       (assert (not (find-package :l)))))
551   ;; Adding back as another package.
552   (assert (eq (find-package :package-local-nicknames-test-1)
553               (add-package-local-nickname :l :package-local-nicknames-test-2
554                                           :package-local-nicknames-test-1)))
555   (let ((*package* (find-package :package-local-nicknames-test-1)))
556     (let ((cons0 (read-from-string "L:CONS"))
557           (exit0 (read-from-string "SB:EXIT"))
558           (cons1 (find-symbol "CONS" :l))
559           (exit1 (find-symbol "EXIT" :sb))
560           (cl (find-package :l))
561           (sb (find-package :sb)))
562       (assert (eq cons0 cons1))
563       (assert (not (eq 'cons cons0)))
564       (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2)
565                   cons0))
566       (assert (equal "L:CONS" (prin1-to-string cons0)))
567       (assert (eq 'sb-ext:exit exit0))
568       (assert (eq 'sb-ext:exit exit1))
569       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
570       (assert (eq cl (find-package :package-local-nicknames-test-2)))
571       (assert (eq sb (find-package :sb-ext)))))
572   ;; Interaction with package locks.
573   (lock-package :package-local-nicknames-test-1)
574   (assert (eq :package-oopsie
575               (handler-case
576                   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
577                 (package-lock-violation ()
578                   :package-oopsie))))
579   (assert (eq :package-oopsie
580               (handler-case
581                   (remove-package-local-nickname :l :package-local-nicknames-test-1)
582                 (package-lock-violation ()
583                   :package-oopsie))))
584   (unlock-package :package-local-nicknames-test-1)
585   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
586   (remove-package-local-nickname :l :package-local-nicknames-test-1))
587
588 (defmacro with-tmp-packages (bindings &body body)
589   `(let ,(mapcar #'car bindings)
590      (unwind-protect
591           (progn
592             (setf ,@(apply #'append bindings))
593             ,@body)
594        ,@(mapcar (lambda (p)
595                    `(when ,p (delete-package ,p)))
596                  (mapcar #'car bindings)))))
597
598 (with-test (:name (:delete-package :locally-nicknames-others))
599   (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
600                       (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
601     (add-package-local-nickname :foo p2 p1)
602     (assert (equal (list p1) (package-locally-nicknamed-by-list p2)))
603     (delete-package p1)
604     (assert (not (package-locally-nicknamed-by-list p2)))))
605
606 (with-test (:name (:delete-package :locally-nicknamed-by-others))
607   (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
608                       (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
609     (add-package-local-nickname :foo p2 p1)
610     (assert (package-local-nicknames p1))
611     (delete-package p2)
612     (assert (not (package-local-nicknames p1)))))
613
614 (with-test (:name :own-name-as-local-nickname)
615   (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
616                       (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
617     (assert (eq :oops
618                 (handler-case
619                     (add-package-local-nickname :own-name-as-nickname1 p2 p1)
620                   (error ()
621                     :oops))))
622     (handler-bind ((error #'continue))
623       (add-package-local-nickname :own-name-as-nickname1 p2 p1))
624     (assert (eq (intern "FOO" p2)
625                 (let ((*package* p1))
626                   (intern "FOO" :own-name-as-nickname1))))))
627
628 (with-test (:name :own-nickname-as-local-nickname)
629   (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
630                                         :nicknames '("OWN-NICKNAME")))
631                       (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
632     (assert (eq :oops
633                 (handler-case
634                     (add-package-local-nickname :own-nickname p2 p1)
635                   (error ()
636                     :oops))))
637     (handler-bind ((error #'continue))
638       (add-package-local-nickname :own-nickname p2 p1))
639     (assert (eq (intern "FOO" p2)
640                 (let ((*package* p1))
641                   (intern "FOO" :own-nickname))))))
642
643 (with-test (:name :delete-package-restart)
644   (let* (ok
645          (result
646            (handler-bind
647                ((sb-kernel:simple-package-error
648                   (lambda (c)
649                     (setf ok t)
650                     (continue c))))
651              (delete-package (gensym)))))
652     (assert ok)
653     (assert (not result))))