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