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