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