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-iterator.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))))