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)
 394     (unwind-protect
 395          (progn
 396            (setf p (eval `(defpackage :package-at-variance-restarts.1
 397                             (:use :cl)
 398                             (:shadow "CONS"))))
 399            (handler-bind ((sb-kernel::package-at-variance-error
 400                             (lambda (c)
 401                               (invoke-restart 'sb-impl::keep-them))))
 402              (eval `(defpackage :package-at-variance-restarts.1
 403                       (:use :cl))))
 404            (assert (not (eq 'cl:cons (intern "CONS" p))))
 405            (handler-bind ((sb-kernel::package-at-variance-error
 406                             (lambda (c)
 407                               (invoke-restart 'sb-impl::drop-them))))
 408              (eval `(defpackage :package-at-variance-restarts.1
 409                       (:use :cl))))
 410            (assert (eq 'cl:cons (intern "CONS" p))))
 411       (when p (delete-package p)))))
 412
 413 (with-test (:name (:package-at-variance-restarts :use))
 414   (let (p)
 415     (unwind-protect
 416          (progn
 417            (setf p (eval `(defpackage :package-at-variance-restarts.2
 418                             (:use :cl))))
 419            (handler-bind ((sb-kernel::package-at-variance-error
 420                             (lambda (c)
 421                               (invoke-restart 'sb-impl::keep-them))))
 422              (eval `(defpackage :package-at-variance-restarts.2
 423                       (:use))))
 424            (assert (eq 'cl:cons (intern "CONS" p)))
 425            (handler-bind ((sb-kernel::package-at-variance-error
 426                             (lambda (c)
 427                               (invoke-restart 'sb-impl::drop-them))))
 428              (eval `(defpackage :package-at-variance-restarts.2
 429                       (:use))))
 430            (assert (not (eq 'cl:cons (intern "CONS" p)))))
 431       (when p (delete-package p)))))
 432
 433 (with-test (:name (:package-at-variance-restarts :export))
 434   (let (p)
 435     (unwind-protect
 436          (progn
 437            (setf p (eval `(defpackage :package-at-variance-restarts.4
 438                             (:export "FOO"))))
 439            (handler-bind ((sb-kernel::package-at-variance-error
 440                             (lambda (c)
 441                               (invoke-restart 'sb-impl::keep-them))))
 442              (eval `(defpackage :package-at-variance-restarts.4)))
 443            (assert (eq :external (nth-value 1 (find-symbol "FOO" p))))
 444            (handler-bind ((sb-kernel::package-at-variance-error
 445                             (lambda (c)
 446                               (invoke-restart 'sb-impl::drop-them))))
 447              (eval `(defpackage :package-at-variance-restarts.4)))
 448            (assert (eq :internal (nth-value 1 (find-symbol "FOO" p)))))
 449       (when p (delete-package p)))))
 450
 451 (with-test (:name (:package-at-variance-restarts :implement))
 452   (let (p)
 453     (unwind-protect
 454          (progn
 455            (setf p (eval `(defpackage :package-at-variance-restarts.5
 456                             (:implement :sb-int))))
 457            (handler-bind ((sb-kernel::package-at-variance-error
 458                             (lambda (c)
 459                               (invoke-restart 'sb-impl::keep-them))))
 460              (eval `(defpackage :package-at-variance-restarts.5)))
 461            (assert (member p (package-implemented-by-list :sb-int)))
 462            (handler-bind ((sb-kernel::package-at-variance-error
 463                             (lambda (c)
 464                               (invoke-restart 'sb-impl::drop-them))))
 465              (eval `(defpackage :package-at-variance-restarts.5)))
 466            (assert (not (member p (package-implemented-by-list :sb-int)))))
 467       (when p (delete-package p)))))
 468
 469 (with-test (:name (:delete-package :implementation-package))
 470   (let (p1 p2)
 471     (unwind-protect
 472          (progn
 473            (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1")
 474                  p2 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2"))
 475            (add-implementation-package p2 p1)
 476            (assert (= 1 (length (package-implemented-by-list p1))))
 477            (delete-package p2)
 478            (assert (= 0 (length (package-implemented-by-list p1)))))
 479       (when p1 (delete-package p1))
 480       (when p2 (delete-package p2)))))
 481
 482 (with-test (:name (:delete-package :implementated-package))
 483   (let (p1 p2)
 484     (unwind-protect
 485          (progn
 486            (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1")
 487                  p2 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2"))
 488            (add-implementation-package p2 p1)
 489            (assert (= 1 (length (package-implements-list p2))))
 490            (delete-package p1)
 491            (assert (= 0 (length (package-implements-list p2)))))
 492       (when p1 (delete-package p1))
 493       (when p2 (delete-package p2)))))
 494
 495 (with-test (:name :package-local-nicknames)
 496   ;; Clear slate
 497   (without-package-locks
 498     (delete-package :package-local-nicknames-test-1)
 499     (delete-package :package-local-nicknames-test-2))
 500   (eval `(defpackage :package-local-nicknames-test-1
 501            (:local-nicknames (:l :cl) (:sb :sb-ext))))
 502   (eval `(defpackage :package-local-nicknames-test-2
 503            (:export "CONS")))
 504   ;; Introspection
 505   (let ((alist (package-local-nicknames :package-local-nicknames-test-1)))
 506     (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=)))
 507     (assert (equal (cons "SB" (find-package "SB-EXT")) (assoc "SB" alist :test 'string=)))
 508     (assert (eql 2 (length alist))))
 509   ;; Usage
 510   (let ((*package* (find-package :package-local-nicknames-test-1)))
 511     (let ((cons0 (read-from-string "L:CONS"))
 512           (exit0 (read-from-string "SB:EXIT"))
 513           (cons1 (find-symbol "CONS" :l))
 514           (exit1 (find-symbol "EXIT" :sb))
 515           (cl (find-package :l))
 516           (sb (find-package :sb)))
 517       (assert (eq 'cons cons0))
 518       (assert (eq 'cons cons1))
 519       (assert (equal "L:CONS" (prin1-to-string cons0)))
 520       (assert (eq 'sb-ext:exit exit0))
 521       (assert (eq 'sb-ext:exit exit1))
 522       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 523       (assert (eq cl (find-package :common-lisp)))
 524       (assert (eq sb (find-package :sb-ext)))))
 525   ;; Can't add same name twice for different global names.
 526   (assert (eq :oopsie
 527               (handler-case
 528                   (add-package-local-nickname :l :package-local-nicknames-test-2
 529                                               :package-local-nicknames-test-1)
 530                 (error ()
 531                   :oopsie))))
 532   ;; But same name twice is OK.
 533   (add-package-local-nickname :l :cl :package-local-nicknames-test-1)
 534   ;; Removal.
 535   (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
 536   (let ((*package* (find-package :package-local-nicknames-test-1)))
 537     (let ((exit0 (read-from-string "SB:EXIT"))
 538           (exit1 (find-symbol "EXIT" :sb))
 539           (sb (find-package :sb)))
 540       (assert (eq 'sb-ext:exit exit0))
 541       (assert (eq 'sb-ext:exit exit1))
 542       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 543       (assert (eq sb (find-package :sb-ext)))
 544       (assert (not (find-package :l)))))
 545   ;; Adding back as another package.
 546   (assert (eq (find-package :package-local-nicknames-test-1)
 547               (add-package-local-nickname :l :package-local-nicknames-test-2
 548                                           :package-local-nicknames-test-1)))
 549   (let ((*package* (find-package :package-local-nicknames-test-1)))
 550     (let ((cons0 (read-from-string "L:CONS"))
 551           (exit0 (read-from-string "SB:EXIT"))
 552           (cons1 (find-symbol "CONS" :l))
 553           (exit1 (find-symbol "EXIT" :sb))
 554           (cl (find-package :l))
 555           (sb (find-package :sb)))
 556       (assert (eq cons0 cons1))
 557       (assert (not (eq 'cons cons0)))
 558       (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2)
 559                   cons0))
 560       (assert (equal "L:CONS" (prin1-to-string cons0)))
 561       (assert (eq 'sb-ext:exit exit0))
 562       (assert (eq 'sb-ext:exit exit1))
 563       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 564       (assert (eq cl (find-package :package-local-nicknames-test-2)))
 565       (assert (eq sb (find-package :sb-ext)))))
 566   ;; Interaction with package locks.
 567   (lock-package :package-local-nicknames-test-1)
 568   (assert (eq :package-oopsie
 569               (handler-case
 570                   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
 571                 (package-lock-violation ()
 572                   :package-oopsie))))
 573   (assert (eq :package-oopsie
 574               (handler-case
 575                   (remove-package-local-nickname :l :package-local-nicknames-test-1)
 576                 (package-lock-violation ()
 577                   :package-oopsie))))
 578   (unlock-package :package-local-nicknames-test-1)
 579   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
 580   (remove-package-local-nickname :l :package-local-nicknames-test-1))
 581
 582 (with-test (:name (:delete-package :locally-nicknames-others))
 583   (let (p1 p2)
 584     (unwind-protect
 585          (progn
 586            (setf p1 (make-package "LOCALLY-NICKNAMES-OTHERS")
 587                  p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS"))
 588                (add-package-local-nickname :foo p2 p1)
 589                (assert (package-locally-nicknamed-by p2))
 590                (delete-package p1)
 591                (assert (not (package-locally-nicknamed-by p2))))
 592       (when p1 (delete-package p1))
 593       (when p2 (delete-package p2)))))
 594
 595 (with-test (:name (:delete-package :locally-nicknamed-by-others))
 596   (let ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
 597         (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
 598     (add-package-local-nickname :foo p2 p1)
 599     (assert (package-local-nicknames p1))
 600     (delete-package p2)
 601     (assert (not (package-local-nicknames p1)))))