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 (defun set-bad-package (x)
  15   (declare (optimize (safety 0)))
  16   (setq *package* x))
  17
  18 ;; When interpreting, the error occurs in SET-BAD-PACKAGE,
  19 ;; not at the INTERN call.
  20 (with-test (:name :set-bad-package :skipped-on :interpreter)
  21   (set-bad-package :cl-user)
  22   (assert-error (intern "FRED") type-error))
  23
  24 (with-test (:name :packages-sanely-nicknamed)
  25   (dolist (p (list-all-packages))
  26     (let* ((nicks (package-nicknames p))
  27            (check (remove-duplicates nicks :test 'string=)))
  28       (assert (= (length check) (length nicks))))))
  29
  30 (make-package "FOO")
  31 (defvar *foo* (find-package (coerce "FOO" 'base-string)))
  32 (rename-package "FOO" (make-array 0 :element-type nil))
  33 (assert (eq *foo* (find-package "")))
  34 (assert (delete-package ""))
  35
  36 (make-package "BAR")
  37 (defvar *baz* (rename-package "BAR" "BAZ"))
  38 (assert (eq *baz* (find-package "BAZ")))
  39 (assert (delete-package *baz*))
  40
  41 (handler-case
  42     (export :foo)
  43   (package-error (c) (princ c))
  44   (:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args)))
  45
  46 (make-package "FOO")
  47 (assert (shadow #\a :foo))
  48
  49 (defpackage :PACKAGE-DESIGNATOR-1 (:use #.(find-package :cl)))
  50
  51 (defpackage :PACKAGE-DESIGNATOR-2
  52   (:import-from #.(find-package :cl) "+"))
  53
  54 (defpackage "EXAMPLE-INDIRECT"
  55   (:import-from "CL" "+"))
  56
  57 (defpackage "EXAMPLE-PACKAGE"
  58   (:shadow "CAR")
  59   (:shadowing-import-from "CL" "CAAR")
  60   (:use)
  61   (:import-from "CL" "CDR")
  62   (:import-from "EXAMPLE-INDIRECT" "+")
  63   (:export "CAR" "CDR" "EXAMPLE"))
  64
  65 (flet ((check-symbol (name expected-status expected-home-name)
  66          (multiple-value-bind (symbol status)
  67              (find-symbol name "EXAMPLE-PACKAGE")
  68            (let ((home (symbol-package symbol))
  69                  (expected-home (find-package expected-home-name)))
  70              (assert (eql home expected-home))
  71              (assert (eql status expected-status))))))
  72   (check-symbol "CAR" :external "EXAMPLE-PACKAGE")
  73   (check-symbol "CDR" :external "CL")
  74   (check-symbol "EXAMPLE" :external "EXAMPLE-PACKAGE")
  75   (check-symbol "CAAR" :internal "CL")
  76   (check-symbol "+" :internal "CL")
  77   (check-symbol "CDDR" nil "CL"))
  78
  79 (defpackage "TEST-ORIGINAL" (:nicknames "A-NICKNAME"))
  80
  81 (assert-error (defpackage "A-NICKNAME"))
  82
  83 (assert (eql (find-package "A-NICKNAME")
  84              (find-package "TEST-ORIGINAL")))
  85
  86 ;;;; Utilities
  87 (defun sym (package name)
  88  (let ((package (or (find-package package) package)))
  89    (multiple-value-bind (symbol status)
  90        (find-symbol name package)
  91      (assert status
  92              (package name symbol status)
  93              "No symbol with name ~A in ~S." name package symbol status)
  94    (values symbol status))))
  95
  96 (defmacro with-name-conflict-resolution ((symbol &key restarted)
  97                                          form &body body)
  98   "Resolves potential name conflict condition arising from FORM.
  99
 100 The conflict is resolved in favour of SYMBOL, a form which must
 101 evaluate to a symbol.
 102
 103 If RESTARTED is a symbol, it is bound for the BODY forms and set to T
 104 if a restart was invoked."
 105   (check-type restarted symbol "a binding name")
 106   (let ((%symbol (copy-symbol 'symbol)))
 107     `(let (,@(when restarted `((,restarted)))
 108            (,%symbol ,symbol))
 109        (handler-bind
 110            ((sb-ext:name-conflict
 111              (lambda (condition)
 112                ,@(when restarted `((setf ,restarted t)))
 113                (assert (member ,%symbol (sb-ext:name-conflict-symbols condition)))
 114                (invoke-restart 'sb-ext:resolve-conflict ,%symbol))))
 115          ,form)
 116        ,@body)))
 117
 118 (defmacro with-packages (specs &body forms)
 119   (let ((names (mapcar #'car specs)))
 120     `(unwind-protect
 121           (progn
 122             (delete-packages ',names)
 123             ,@(mapcar (lambda (spec)
 124                         `(defpackage ,@spec))
 125                       specs)
 126             ,@forms)
 127        (delete-packages ',names))))
 128
 129 (defun delete-packages (names)
 130   (dolist (p names)
 131     (ignore-errors (delete-package p))))
 132
 133
 134 ;;;; Tests
 135 ;;; USE-PACKAGE
 136 (with-test (:name :use-package.1)
 137   (with-packages (("FOO" (:export "SYM"))
 138                   ("BAR" (:export "SYM"))
 139                   ("BAZ" (:use)))
 140     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
 141         (use-package '("FOO" "BAR") "BAZ")
 142       (is restartedp)
 143       (is (eq (sym "BAR" "SYM")
 144               (sym "BAZ" "SYM"))))))
 145
 146 (with-test (:name :use-package.2)
 147   (with-packages (("FOO" (:export "SYM"))
 148                   ("BAZ" (:use) (:intern "SYM")))
 149     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 150         (use-package "FOO" "BAZ")
 151       (is restartedp)
 152       (is (eq (sym "FOO" "SYM")
 153               (sym "BAZ" "SYM"))))))
 154
 155 (with-test (:name :use-package.2a)
 156   (with-packages (("FOO" (:export "SYM"))
 157                   ("BAZ" (:use) (:intern "SYM")))
 158     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
 159         (use-package "FOO" "BAZ")
 160       (is restartedp)
 161       (is (equal (list (sym "BAZ" "SYM") :internal)
 162                  (multiple-value-list (sym "BAZ" "SYM")))))))
 163
 164 (with-test (:name :use-package-conflict-set :fails-on :sbcl)
 165   (with-packages (("FOO" (:export "SYM"))
 166                   ("QUX" (:export "SYM"))
 167                   ("BAR" (:intern "SYM"))
 168                   ("BAZ" (:use) (:import-from "BAR" "SYM")))
 169     (let ((conflict-set))
 170       (block nil
 171         (handler-bind
 172             ((sb-ext:name-conflict
 173               (lambda (condition)
 174                 (setf conflict-set (copy-list
 175                                     (sb-ext:name-conflict-symbols condition)))
 176                 (return))))
 177           (use-package '("FOO" "QUX") "BAZ")))
 178       (setf conflict-set
 179             (sort conflict-set #'string<
 180                   :key (lambda (symbol)
 181                          (package-name (symbol-package symbol)))))
 182       (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM"))
 183                  conflict-set)))))
 184
 185 ;;; EXPORT
 186 (with-test (:name :export.1)
 187   (with-packages (("FOO" (:intern "SYM"))
 188                   ("BAR" (:export "SYM"))
 189                   ("BAZ" (:use "FOO" "BAR")))
 190     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 191         (export (sym "FOO" "SYM") "FOO")
 192       (is restartedp)
 193       (is (eq (sym "FOO" "SYM")
 194               (sym "BAZ" "SYM"))))))
 195
 196 (with-test (:name :export.1a)
 197   (with-packages (("FOO" (:intern "SYM"))
 198                   ("BAR" (:export "SYM"))
 199                   ("BAZ" (:use "FOO" "BAR")))
 200     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
 201         (export (sym "FOO" "SYM") "FOO")
 202       (is restartedp)
 203       (is (eq (sym "BAR" "SYM")
 204               (sym "BAZ" "SYM"))))))
 205
 206 (with-test (:name :export.ensure-exported)
 207   (with-packages (("FOO" (:intern "SYM"))
 208                   ("BAR" (:export "SYM"))
 209                   ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM")))
 210     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 211         (export (sym "FOO" "SYM") "FOO")
 212       (is restartedp)
 213       (is (equal (list (sym "FOO" "SYM") :external)
 214                  (multiple-value-list (sym "FOO" "SYM"))))
 215       (is (eq (sym "FOO" "SYM")
 216               (sym "BAZ" "SYM"))))))
 217
 218 (with-test (:name :export.3.intern)
 219   (with-packages (("FOO" (:intern "SYM"))
 220                   ("BAZ" (:use "FOO") (:intern "SYM")))
 221     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 222         (export (sym "FOO" "SYM") "FOO")
 223       (is restartedp)
 224       (is (eq (sym "FOO" "SYM")
 225               (sym "BAZ" "SYM"))))))
 226
 227 (with-test (:name :export.3a.intern)
 228   (with-packages (("FOO" (:intern "SYM"))
 229                   ("BAZ" (:use "FOO") (:intern "SYM")))
 230     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
 231         (export (sym "FOO" "SYM") "FOO")
 232       (is restartedp)
 233       (is (equal (list (sym "BAZ" "SYM") :internal)
 234                  (multiple-value-list (sym "BAZ" "SYM")))))))
 235
 236 ;;; IMPORT
 237 (with-test (:name :import-nil.1)
 238   (with-packages (("FOO" (:use) (:intern "NIL"))
 239                   ("BAZ" (:use) (:intern "NIL")))
 240     (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp)
 241         (import (list (sym "FOO" "NIL")) "BAZ")
 242       (is restartedp)
 243       (is (eq (sym "FOO" "NIL")
 244               (sym "BAZ" "NIL"))))))
 245
 246 (with-test (:name :import-nil.2)
 247   (with-packages (("BAZ" (:use) (:intern "NIL")))
 248     (with-name-conflict-resolution ('CL:NIL :restarted restartedp)
 249         (import '(CL:NIL) "BAZ")
 250       (is restartedp)
 251       (is (eq 'CL:NIL
 252               (sym "BAZ" "NIL"))))))
 253
 254 (with-test (:name :import-single-conflict :fails-on :sbcl)
 255   (with-packages (("FOO" (:export "NIL"))
 256                   ("BAR" (:export "NIL"))
 257                   ("BAZ" (:use)))
 258     (let ((conflict-sets '()))
 259       (handler-bind
 260           ((sb-ext:name-conflict
 261             (lambda (condition)
 262               (push (copy-list (sb-ext:name-conflict-symbols condition))
 263                     conflict-sets)
 264               (invoke-restart 'sb-ext:resolve-conflict 'CL:NIL))))
 265         (import (list 'CL:NIL (sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ"))
 266       (is (eql 1 (length conflict-sets)))
 267       (is (eql 3 (length (first conflict-sets)))))))
 268
 269 ;;; Make sure that resolving a name-conflict in IMPORT doesn't leave
 270 ;;; multiple symbols of the same name in the package (this particular
 271 ;;; scenario found in 1.0.38.9, but clearly a longstanding issue).
 272 (with-test (:name :import-conflict-resolution)
 273   (with-packages (("FOO" (:export "NIL"))
 274                   ("BAR" (:use)))
 275     (with-name-conflict-resolution ((sym "FOO" "NIL"))
 276       (import (list 'CL:NIL (sym "FOO" "NIL")) "BAR"))
 277     (do-symbols (sym "BAR")
 278       (assert (eq sym (sym "FOO" "NIL"))))))
 279
 280 ;;; UNINTERN
 281 (with-test (:name :unintern.1)
 282   (with-packages (("FOO" (:export "SYM"))
 283                   ("BAR" (:export "SYM"))
 284                   ("BAZ" (:use "FOO" "BAR") (:shadow "SYM")))
 285     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 286         (unintern (sym "BAZ" "SYM") "BAZ")
 287       (is restartedp)
 288       (is (eq (sym "FOO" "SYM")
 289               (sym "BAZ" "SYM"))))))
 290
 291 (with-test (:name :unintern.2)
 292   (with-packages (("FOO" (:intern "SYM")))
 293     (unintern :sym "FOO")
 294     (assert (find-symbol "SYM" "FOO"))))
 295
 296 ;;; WITH-PACKAGE-ITERATOR error signalling had problems
 297 (with-test (:name :with-package-iterator.error)
 298   (assert (eq :good
 299               (handler-case
 300                   (progn
 301                     (eval '(with-package-iterator (sym :cl-user :foo)
 302                             (sym)))
 303                     :bad)
 304                 ((and simple-condition program-error) (c)
 305                   (assert (equal (list :foo) (simple-condition-format-arguments c)))
 306                   :good)))))
 307
 308 ;; X3J13 writeup HASH-TABLE-PACKAGE-GENERATORS says
 309 ;;  "An argument of NIL is treated as an empty list of packages."
 310 ;; This used to fail with "NIL does not name a package"
 311 (with-test (:name :with-package-iterator-nil-list)
 312   (with-package-iterator (iter '() :internal)
 313     (assert (null (iter)))))
 314
 315 ;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
 316 (with-test (:name :bug-511072 :skipped-on '(not :sb-thread))
 317   (let* ((p (make-package :bug-511072))
 318          (sem1 (sb-thread:make-semaphore))
 319          (sem2 (sb-thread:make-semaphore))
 320          (t2 (make-join-thread (lambda ()
 321                                  (handler-bind ((error (lambda (c)
 322                                                          (sb-thread:signal-semaphore sem1)
 323                                                          (sb-thread:wait-on-semaphore sem2)
 324                                                          (abort c))))
 325                                    (make-package :bug-511072))))))
 326     (declare (ignore p t2))
 327     (sb-thread:wait-on-semaphore sem1)
 328     (with-timeout 10
 329       (assert (eq 'cons (read-from-string "CL:CONS"))))
 330     (sb-thread:signal-semaphore sem2)))
 331
 332 (defmacro handling ((condition restart-name) form)
 333   `(handler-bind ((,condition (lambda (c)
 334                                 (declare (ignore c))
 335                                 (invoke-restart ',restart-name))))
 336      ,form))
 337
 338
 339 (with-test (:name :quick-name-conflict-resolution-import)
 340   (let (p1 p2)
 341     (unwind-protect
 342          (progn
 343            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1")
 344                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2"))
 345            (intern "FOO" p1)
 346            (handling (name-conflict sb-impl::dont-import-it)
 347              (import (intern "FOO" p2) p1))
 348            (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
 349            (handling (name-conflict sb-impl::shadowing-import-it)
 350              (import (intern "FOO" p2) p1))
 351            (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
 352       (when p1 (delete-package p1))
 353       (when p2 (delete-package p2)))))
 354
 355 (with-test (:name :quick-name-conflict-resolution-export.1)
 356   (let (p1 p2)
 357     (unwind-protect
 358          (progn
 359            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a")
 360                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a"))
 361            (intern "FOO" p1)
 362            (use-package p2 p1)
 363            (handling (name-conflict sb-impl::keep-old)
 364              (export (intern "FOO" p2) p2))
 365            (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))))
 366       (when p1 (delete-package p1))
 367       (when p2 (delete-package p2)))))
 368
 369 (with-test (:name :quick-name-conflict-resolution-export.2)
 370   (let (p1 p2)
 371     (unwind-protect
 372          (progn
 373            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b")
 374                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b"))
 375            (intern "FOO" p1)
 376            (use-package p2 p1)
 377            (handling (name-conflict sb-impl::take-new)
 378              (export (intern "FOO" p2) p2))
 379            (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
 380       (when p1 (delete-package p1))
 381       (when p2 (delete-package p2)))))
 382
 383 (with-test (:name :quick-name-conflict-resolution-use-package.1)
 384   (let (p1 p2)
 385     (unwind-protect
 386          (progn
 387            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a")
 388                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a"))
 389            (intern "FOO" p1)
 390            (intern "BAR" p1)
 391            (export (intern "FOO" p2) p2)
 392            (export (intern "BAR" p2) p2)
 393            (handling (name-conflict sb-impl::keep-old)
 394              (use-package p2 p1))
 395            (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
 396            (assert (not (eq (intern "BAR" p1) (intern "BAR" p2)))))
 397       (when p1 (delete-package p1))
 398       (when p2 (delete-package p2)))))
 399
 400 (with-test (:name :quick-name-conflict-resolution-use-package.2)
 401   (let (p1 p2)
 402     (unwind-protect
 403          (progn
 404            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b")
 405                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b"))
 406            (intern "FOO" p1)
 407            (intern "BAR" p1)
 408            (export (intern "FOO" p2) p2)
 409            (export (intern "BAR" p2) p2)
 410            (handling (name-conflict sb-impl::take-new)
 411              (use-package p2 p1))
 412            (assert (eq (intern "FOO" p1) (intern "FOO" p2)))
 413            (assert (eq (intern "BAR" p1) (intern "BAR" p2))))
 414       (when p1 (delete-package p1))
 415       (when p2 (delete-package p2)))))
 416
 417 (with-test (:name (:package-at-variance-restarts :shadow))
 418   (let ((p nil)
 419         (*on-package-variance* '(:error t)))
 420     (unwind-protect
 421          (progn
 422            (setf p (eval `(defpackage :package-at-variance-restarts.1
 423                             (:use :cl)
 424                             (:shadow "CONS"))))
 425            (handling (sb-kernel::package-at-variance-error sb-impl::keep-them)
 426              (eval `(defpackage :package-at-variance-restarts.1
 427                       (:use :cl))))
 428            (assert (not (eq 'cl:cons (intern "CONS" p))))
 429            (handling (sb-kernel::package-at-variance-error sb-impl::drop-them)
 430              (eval `(defpackage :package-at-variance-restarts.1
 431                       (:use :cl))))
 432            (assert (eq 'cl:cons (intern "CONS" p))))
 433       (when p (delete-package p)))))
 434
 435 (with-test (:name (:package-at-variance-restarts :use))
 436   (let ((p nil)
 437         (*on-package-variance* '(:error t)))
 438     (unwind-protect
 439          (progn
 440            (setf p (eval `(defpackage :package-at-variance-restarts.2
 441                             (:use :cl))))
 442            (handling (sb-kernel::package-at-variance-error sb-impl::keep-them)
 443              (eval `(defpackage :package-at-variance-restarts.2
 444                       (:use))))
 445            (assert (eq 'cl:cons (intern "CONS" p)))
 446            (handling (sb-kernel::package-at-variance-error sb-impl::drop-them)
 447              (eval `(defpackage :package-at-variance-restarts.2
 448                       (:use))))
 449            (assert (not (eq 'cl:cons (intern "CONS" p)))))
 450       (when p (delete-package p)))))
 451
 452 (with-test (:name (:package-at-variance-restarts :export))
 453   (let ((p nil)
 454         (*on-package-variance* '(:error t)))
 455     (unwind-protect
 456          (progn
 457            (setf p (eval `(defpackage :package-at-variance-restarts.4
 458                             (:export "FOO"))))
 459            (handling (sb-kernel::package-at-variance-error sb-impl::keep-them)
 460              (eval `(defpackage :package-at-variance-restarts.4)))
 461            (assert (eq :external (nth-value 1 (find-symbol "FOO" p))))
 462            (handling (sb-kernel::package-at-variance-error 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)))))
 466
 467 (with-test (:name (:package-at-variance-restarts :implement))
 468   (let ((p nil)
 469         (*on-package-variance* '(:error t)))
 470     (unwind-protect
 471          (progn
 472            (setf p (eval `(defpackage :package-at-variance-restarts.5
 473                             (:implement :sb-int))))
 474            (handling (sb-kernel::package-at-variance-error sb-impl::keep-them)
 475              (eval `(defpackage :package-at-variance-restarts.5)))
 476            (assert (member p (package-implemented-by-list :sb-int)))
 477            (handling (sb-kernel::package-at-variance-error sb-impl::drop-them)
 478              (eval `(defpackage :package-at-variance-restarts.5)))
 479            (assert (not (member p (package-implemented-by-list :sb-int)))))
 480       (when p (delete-package p)))))
 481
 482 (with-test (:name (:delete-package :implementation-package))
 483   (let (p1 p2)
 484     (unwind-protect
 485          (progn
 486            (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1")
 487                  p2 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2"))
 488            (add-implementation-package p2 p1)
 489            (assert (= 1 (length (package-implemented-by-list p1))))
 490            (delete-package p2)
 491            (assert (= 0 (length (package-implemented-by-list p1)))))
 492       (when p1 (delete-package p1))
 493       (when p2 (delete-package p2)))))
 494
 495 (with-test (:name (:delete-package :implementated-package))
 496   (let (p1 p2)
 497     (unwind-protect
 498          (progn
 499            (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1")
 500                  p2 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2"))
 501            (add-implementation-package p2 p1)
 502            (assert (= 1 (length (package-implements-list p2))))
 503            (delete-package p1)
 504            (assert (= 0 (length (package-implements-list p2)))))
 505       (when p1 (delete-package p1))
 506       (when p2 (delete-package p2)))))
 507
 508 (with-test (:name :package-local-nicknames)
 509   ;; Clear slate
 510   (without-package-locks
 511     (when (find-package :package-local-nicknames-test-1)
 512       (delete-package :package-local-nicknames-test-1))
 513     (when (find-package :package-local-nicknames-test-2)
 514       (delete-package :package-local-nicknames-test-2)))
 515   (eval `(defpackage :package-local-nicknames-test-1
 516            (:local-nicknames (:l :cl) (:sb :sb-ext))))
 517   (eval `(defpackage :package-local-nicknames-test-2
 518            (:export "CONS")))
 519   ;; Introspection
 520   (let ((alist (package-local-nicknames :package-local-nicknames-test-1)))
 521     (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=)))
 522     (assert (equal (cons "SB" (find-package "SB-EXT")) (assoc "SB" alist :test 'string=)))
 523     (assert (eql 2 (length alist))))
 524   ;; Usage
 525   (let ((*package* (find-package :package-local-nicknames-test-1)))
 526     (let ((cons0 (read-from-string "L:CONS"))
 527           (exit0 (read-from-string "SB:EXIT"))
 528           (cons1 (find-symbol "CONS" :l))
 529           (exit1 (find-symbol "EXIT" :sb))
 530           (cl (find-package :l))
 531           (sb (find-package :sb)))
 532       (assert (eq 'cons cons0))
 533       (assert (eq 'cons cons1))
 534       (assert (equal "L:CONS" (prin1-to-string cons0)))
 535       (assert (eq 'sb-ext:exit exit0))
 536       (assert (eq 'sb-ext:exit exit1))
 537       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 538       (assert (eq cl (find-package :common-lisp)))
 539       (assert (eq sb (find-package :sb-ext)))))
 540   ;; Can't add same name twice for different global names.
 541   (assert (eq :oopsie
 542               (handler-case
 543                   (add-package-local-nickname :l :package-local-nicknames-test-2
 544                                               :package-local-nicknames-test-1)
 545                 (error ()
 546                   :oopsie))))
 547   ;; But same name twice is OK.
 548   (add-package-local-nickname :l :cl :package-local-nicknames-test-1)
 549   ;; Removal.
 550   (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
 551   (let ((*package* (find-package :package-local-nicknames-test-1)))
 552     (let ((exit0 (read-from-string "SB:EXIT"))
 553           (exit1 (find-symbol "EXIT" :sb))
 554           (sb (find-package :sb)))
 555       (assert (eq 'sb-ext:exit exit0))
 556       (assert (eq 'sb-ext:exit exit1))
 557       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 558       (assert (eq sb (find-package :sb-ext)))
 559       (assert (not (find-package :l)))))
 560   ;; Adding back as another package.
 561   (assert (eq (find-package :package-local-nicknames-test-1)
 562               (add-package-local-nickname :l :package-local-nicknames-test-2
 563                                           :package-local-nicknames-test-1)))
 564   (let ((*package* (find-package :package-local-nicknames-test-1)))
 565     (let ((cons0 (read-from-string "L:CONS"))
 566           (exit0 (read-from-string "SB:EXIT"))
 567           (cons1 (find-symbol "CONS" :l))
 568           (exit1 (find-symbol "EXIT" :sb))
 569           (cl (find-package :l))
 570           (sb (find-package :sb)))
 571       (assert (eq cons0 cons1))
 572       (assert (not (eq 'cons cons0)))
 573       (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2)
 574                   cons0))
 575       (assert (equal "L:CONS" (prin1-to-string cons0)))
 576       (assert (eq 'sb-ext:exit exit0))
 577       (assert (eq 'sb-ext:exit exit1))
 578       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 579       (assert (eq cl (find-package :package-local-nicknames-test-2)))
 580       (assert (eq sb (find-package :sb-ext)))))
 581   ;; Interaction with package locks.
 582   (lock-package :package-local-nicknames-test-1)
 583   (assert (eq :package-oopsie
 584               (handler-case
 585                   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
 586                 (package-lock-violation ()
 587                   :package-oopsie))))
 588   (assert (eq :package-oopsie
 589               (handler-case
 590                   (remove-package-local-nickname :l :package-local-nicknames-test-1)
 591                 (package-lock-violation ()
 592                   :package-oopsie))))
 593   (unlock-package :package-local-nicknames-test-1)
 594   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
 595   (remove-package-local-nickname :l :package-local-nicknames-test-1))
 596
 597 (defmacro with-tmp-packages (bindings &body body)
 598   `(let ,(mapcar #'car bindings)
 599      (unwind-protect
 600           (progn
 601             (setf ,@(apply #'append bindings))
 602             ,@body)
 603        ,@(mapcar (lambda (p)
 604                    `(when ,p (delete-package ,p)))
 605                  (mapcar #'car bindings)))))
 606
 607 (with-test (:name (:delete-package :locally-nicknames-others))
 608   (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
 609                       (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
 610     (add-package-local-nickname :foo p2 p1)
 611     (assert (equal (list p1) (package-locally-nicknamed-by-list p2)))
 612     (delete-package p1)
 613     (assert (not (package-locally-nicknamed-by-list p2)))))
 614
 615 (with-test (:name (:delete-package :locally-nicknamed-by-others))
 616   (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
 617                       (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
 618     (add-package-local-nickname :foo p2 p1)
 619     (assert (package-local-nicknames p1))
 620     (delete-package p2)
 621     (assert (not (package-local-nicknames p1)))))
 622
 623 (with-test (:name :own-name-as-local-nickname)
 624   (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
 625                       (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
 626     (assert (eq :oops
 627                 (handler-case
 628                     (add-package-local-nickname :own-name-as-nickname1 p2 p1)
 629                   (error ()
 630                     :oops))))
 631     (handler-bind ((error #'continue))
 632       (add-package-local-nickname :own-name-as-nickname1 p2 p1))
 633     (assert (eq (intern "FOO" p2)
 634                 (let ((*package* p1))
 635                   (intern "FOO" :own-name-as-nickname1))))))
 636
 637 (with-test (:name :own-nickname-as-local-nickname)
 638   (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
 639                                         :nicknames '("OWN-NICKNAME")))
 640                       (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
 641     (assert (eq :oops
 642                 (handler-case
 643                     (add-package-local-nickname :own-nickname p2 p1)
 644                   (error ()
 645                     :oops))))
 646     (handler-bind ((error #'continue))
 647       (add-package-local-nickname :own-nickname p2 p1))
 648     (assert (eq (intern "FOO" p2)
 649                 (let ((*package* p1))
 650                   (intern "FOO" :own-nickname))))))
 651
 652 (with-test (:name :delete-package-restart)
 653   (let* (ok
 654          (result
 655            (handler-bind
 656                ((sb-kernel:simple-package-error
 657                   (lambda (c)
 658                     (setf ok t)
 659                     (continue c))))
 660              (delete-package (gensym)))))
 661     (assert ok)
 662     (assert (not result))))
 663
 664 ;; WITH-PACKAGE-ITERATOR isn't well-exercised by tests (though LOOP uses it)
 665 ;; so here's a basic correctness test with some complications involving
 666 ;; shadowing symbols.
 667 (make-package "P1" :use '("SB-FORMAT"))
 668 (make-package "P2")
 669 (export 'p1::foo 'p1)
 670 (shadow "FORMAT-ERROR" 'p1)
 671 (make-package "A" :use '("SB-FORMAT" "P1" "P2"))
 672 (shadow '("PROG2" "FOO") 'a)
 673 (intern "BLAH" "P2")
 674 (export 'p2::(foo bar baz) 'p2)
 675 (export 'a::goodfun 'a)
 676
 677 (with-test (:name :with-package-iterator)
 678   (let ((tests '((:internal) (:external) (:inherited)
 679                  (:internal :inherited)
 680                  (:internal :external)
 681                  (:external :inherited)
 682                  (:internal :external :inherited)))
 683         (maximum-answer
 684          '(;; symbols visible in A
 685            (a::prog2 :internal "A")
 686            (a::foo :internal "A")
 687            (a:goodfun :external "A")
 688            (p2:bar :inherited "A")
 689            (p2:baz :inherited "A")
 690            (sb-format:%compiler-walk-format-string :inherited "A")
 691            (sb-format:format-error :inherited "A")
 692            ;; ... P1
 693            (p1:foo :external "P1")
 694            (p1::format-error :internal "P1")
 695            (sb-format:%compiler-walk-format-string :inherited "P1")
 696            ;; ... P2
 697            (p2::blah :internal "P2")
 698            (p2:foo :external "P2")
 699            (p2:bar :external "P2")
 700            (p2:baz :external "P2"))))
 701     ;; Compile a new function to test each combination of
 702     ;; accessibility-kind since the macro doesn't eval them.
 703     (dolist (access tests)
 704       ; (print `(testing ,access))
 705       (let ((f (compile
 706                 nil
 707                 `(lambda ()
 708                    (with-package-iterator (iter '(p1 a p2) ,@access)
 709                      (let (res)
 710                        (loop
 711                         (multiple-value-bind (foundp sym access pkg) (iter)
 712                           (if foundp
 713                               (push (list sym access (package-name pkg)) res)
 714                               (return))))
 715                        res))))))
 716         (let ((answer (funcall f))
 717               (expect (remove-if-not (lambda (x) (member (second x) access))
 718                                      maximum-answer)))
 719           ;; exactly as many results as expected
 720           (assert (equal (length answer) (length expect)))
 721           ;; each result is right
 722           (assert (equal (length (intersection answer expect :test #'equal))
 723                          (length expect))))))))
 724
 725 ;; Assert that changes in size of a package-hashtable's symbol vector
 726 ;; do not cause WITH-PACKAGE-ITERATOR to crash. The vector shouldn't grow,
 727 ;; because it is not permitted to INTERN new symbols, but it can shrink
 728 ;; because it is expressly permitted to UNINTERN the current symbol.
 729 ;; (In fact we allow INTERN, but that's beside the point)
 730 (with-test (:name :with-package-iterator-and-mutation)
 731   (flet ((table-size (pkg)
 732            (length (sb-impl::package-hashtable-cells
 733                     (sb-impl::package-internal-symbols pkg)))))
 734     (let* ((p (make-package (string (gensym))))
 735            (initial-table-size (table-size p))
 736            (strings
 737             '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m")))
 738       (dolist (x strings)
 739         (intern x p))
 740       (let ((grown-table-size (table-size p)))
 741         (assert (> grown-table-size initial-table-size))
 742         (let ((n 0))
 743           (with-package-iterator (iter p :internal)
 744             (loop (multiple-value-bind (foundp sym) (iter)
 745                     (cond (foundp
 746                            (incf n)
 747                            (unintern sym p))
 748                           (t
 749                            (return)))))
 750             (assert (= n (length strings)))
 751             ;; while we're at it, assert that calling the iterator
 752             ;; a couple more times returns nothing.
 753             (dotimes (i 2)
 754               (assert (not (iter))))))
 755         (let ((shrunk-table-size (table-size p)))
 756           (assert (< shrunk-table-size grown-table-size)))))))
 757
 758 ;; example from CLHS
 759 (with-test (:name :do-symbols-block-scope)
 760   (assert (eq t
 761               (block nil
 762                 (do-symbols (s (or (find-package "FROB") (return nil)))
 763                   (print s))
 764                 t))))
 765
 766 (with-test (:name :export-inaccessible-lookalike)
 767   (make-package "E1")
 768   (make-package "E2")
 769   (export (intern "A" "E2") 'e2)
 770   (multiple-value-bind (answer condition)
 771       (ignore-errors  (export (intern "A" "E1") 'e2))
 772     (assert (and (not answer)
 773                  (and (typep condition 'sb-kernel:simple-package-error)
 774                       (search "not accessible"
 775                               (simple-condition-format-control condition)))))))
 776
 777 ;; Concurrent FIND-SYMBOL was adversely affected by package rehash.
 778 ;; It's slightly difficult to show that this is fixed, because this
 779 ;; test only sometimes failed prior to the fix. Now it never fails though.
 780 (with-test (:name :concurrent-find-symbol :skipped-on '(not :sb-thread))
 781  (let ((pkg (make-package (gensym)))
 782        (threads)
 783        (names)
 784        (run nil))
 785    (dotimes (i 50)
 786      (let ((s (string (gensym "FRED"))))
 787        (push s names)
 788        (intern s pkg)))
 789    (dotimes (i 5)
 790      (push (sb-thread:make-thread
 791             (lambda ()
 792               (wait-for run)
 793               (let ((n-missing 0))
 794                 (dotimes (i 10 n-missing)
 795                   (dolist (name names)
 796                     (unless (find-symbol name pkg)
 797                       (incf n-missing)))))))
 798            threads))
 799    (setq run t)
 800    ;; Interning new symbols can't cause the pre-determined
 801    ;; 50 names to transiently disappear.
 802    (let ((s (make-string 3))
 803          (alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZ012345"))
 804      (dotimes (i (expt 32 3))
 805        (setf (char s 0) (char alphabet (ldb (byte 5 10) i))
 806              (char s 1) (char alphabet (ldb (byte 5  5) i))
 807              (char s 2) (char alphabet (ldb (byte 5  0) i)))
 808        (intern s pkg)))
 809    (let ((tot-missing 0))
 810      (dolist (thread threads (assert (zerop tot-missing)))
 811        (incf tot-missing (sb-thread:join-thread thread))))))
 812
 813 (with-test (:name :defpackage-multiple-nicknames)
 814   (let* ((name1 (string (gensym)))
 815          (name2 (string (gensym)))
 816          (names (package-nicknames
 817                  (eval `(defpackage ,(gensym)
 818                           (:nicknames ,name1)
 819                           (:nicknames ,name2))))))
 820     (assert (or (equal
 821                  names
 822                  (list name1 name2))
 823                 (equal
 824                  names
 825                  (list name2 name1))))))