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 (load "compiler-test-util.lisp")
  15
  16 (require :sb-md5)
  17 #+64-bit
  18 (progn
  19   (let ((n 0))
  20     (do-all-symbols (s)
  21       (when (> (sb-kernel:symbol-package-id s) 100) (incf n)))
  22     (assert (= n 0))))
  23
  24 (defun set-bad-package (x)
  25   (declare (optimize (safety 0)))
  26   (setq *package* x))
  27
  28 ;; When interpreting, the error occurs in SET-BAD-PACKAGE,
  29 ;; not at the INTERN call.
  30 (with-test (:name :set-bad-package :skipped-on :interpreter)
  31   (set-bad-package :cl-user)
  32   (assert-error (intern "FRED") type-error))
  33
  34 ;;; Expect an error about the nickname not being a string designator,
  35 ;;; not about the nickname being taken by another package.
  36 (with-test (:name :nickname-is-string-designator)
  37   (let ((errmsg (handler-case (make-package "X" :nicknames (list (find-package "CL")))
  38                   (error (c) (princ-to-string c)))))
  39     (assert (search "does not designate a string" errmsg))))
  40
  41 (with-test (:name :packages-sanely-nicknamed)
  42   (dolist (p (list-all-packages))
  43     (let* ((nicks (package-nicknames p))
  44            (check (remove-duplicates nicks :test 'string=)))
  45       (assert (= (length check) (length nicks))))))
  46
  47 (make-package "FOO")
  48 (defvar *foo* (find-package (coerce "FOO" 'base-string)))
  49 (rename-package "FOO" (make-array 0 :element-type 'character))
  50 (assert (eq *foo* (find-package "")))
  51 (assert (delete-package ""))
  52
  53 (make-package "BAR")
  54 (defvar *baz* (rename-package "BAR" "BAZ"))
  55 (assert (eq *baz* (find-package "BAZ")))
  56 (assert (delete-package *baz*))
  57
  58 (handler-case
  59     (export :foo)
  60   (package-error (c) (princ c))
  61   (:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args)))
  62
  63 (make-package "FOO")
  64 (assert (shadow #\a :foo))
  65
  66 (defpackage :PACKAGE-DESIGNATOR-1 (:use #.(find-package :cl)))
  67
  68 (defpackage :PACKAGE-DESIGNATOR-2
  69   (:import-from #.(find-package :cl) "+"))
  70
  71 (defpackage "EXAMPLE-INDIRECT"
  72   (:import-from "CL" "+"))
  73
  74 (defpackage "EXAMPLE-PACKAGE"
  75   (:shadow "CAR")
  76   (:shadowing-import-from "CL" "CAAR")
  77   (:use)
  78   (:import-from "CL" "CDR")
  79   (:import-from "EXAMPLE-INDIRECT" "+")
  80   (:export "CAR" "CDR" "EXAMPLE"))
  81
  82 (flet ((check-symbol (name expected-status expected-home-name)
  83          (multiple-value-bind (symbol status)
  84              (find-symbol name "EXAMPLE-PACKAGE")
  85            (let ((home (symbol-package symbol))
  86                  (expected-home (find-package expected-home-name)))
  87              (assert (eql home expected-home))
  88              (assert (eql status expected-status))))))
  89   (check-symbol "CAR" :external "EXAMPLE-PACKAGE")
  90   (check-symbol "CDR" :external "CL")
  91   (check-symbol "EXAMPLE" :external "EXAMPLE-PACKAGE")
  92   (check-symbol "CAAR" :internal "CL")
  93   (check-symbol "+" :internal "CL")
  94   (check-symbol "CDDR" nil "CL"))
  95
  96 (defpackage "TEST-ORIGINAL" (:nicknames "A-NICKNAME"))
  97
  98 (assert-error (defpackage "A-NICKNAME"))
  99
 100 (assert (eql (find-package "A-NICKNAME")
 101              (find-package "TEST-ORIGINAL")))
 102
 103 ;;;; Utilities
 104 (defun sym (package name)
 105  (let ((package (or (find-package package) package)))
 106    (multiple-value-bind (symbol status)
 107        (find-symbol name package)
 108      (assert status
 109              (package name symbol status)
 110              "No symbol with name ~A in ~S." name package symbol status)
 111    (values symbol status))))
 112
 113 (defmacro with-name-conflict-resolution ((symbol &key restarted)
 114                                          form &body body)
 115   "Resolves potential name conflict condition arising from FORM.
 116
 117 The conflict is resolved in favour of SYMBOL, a form which must
 118 evaluate to a symbol.
 119
 120 If RESTARTED is a symbol, it is bound for the BODY forms and set to T
 121 if a restart was invoked."
 122   (check-type restarted symbol "a binding name")
 123   (let ((%symbol (copy-symbol 'symbol)))
 124     `(let (,@(when restarted `((,restarted)))
 125            (,%symbol ,symbol))
 126        (handler-bind
 127            ((sb-ext:name-conflict
 128              (lambda (condition)
 129                ,@(when restarted `((setf ,restarted t)))
 130                (assert (member ,%symbol (sb-ext:name-conflict-symbols condition)))
 131                (invoke-restart 'sb-ext:resolve-conflict ,%symbol))))
 132          ,form)
 133        ,@body)))
 134
 135 (defmacro with-packages (specs &body forms)
 136   (let ((names (mapcar #'car specs)))
 137     `(unwind-protect
 138           (progn
 139             (delete-packages ',names)
 140             ,@(mapcar (lambda (spec)
 141                         `(defpackage ,@spec))
 142                       specs)
 143             ,@forms)
 144        (delete-packages ',names))))
 145
 146 (defun delete-packages (names)
 147   (dolist (p names)
 148     (ignore-errors (delete-package p))))
 149
 150
 151 ;;;; Tests
 152 ;;; USE-PACKAGE
 153 (with-test (:name :use-keyword-nope)
 154   (assert-error (use-package "KEYWORD"))
 155   (assert-error (use-package "CL-USER" "KEYWORD")))
 156
 157 (with-test (:name :use-package.1)
 158   (with-packages (("FOO" (:export "SYM"))
 159                   ("BAR" (:export "SYM"))
 160                   ("BAZ" (:use)))
 161     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
 162         (use-package '("FOO" "BAR") "BAZ")
 163       (is restartedp)
 164       (is (eq (sym "BAR" "SYM")
 165               (sym "BAZ" "SYM"))))))
 166
 167 (with-test (:name :use-package.2)
 168   (with-packages (("FOO" (:export "SYM"))
 169                   ("BAZ" (:use) (:intern "SYM")))
 170     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 171         (use-package "FOO" "BAZ")
 172       (is restartedp)
 173       (is (eq (sym "FOO" "SYM")
 174               (sym "BAZ" "SYM"))))))
 175
 176 (with-test (:name :use-package.2a)
 177   (with-packages (("FOO" (:export "SYM"))
 178                   ("BAZ" (:use) (:intern "SYM")))
 179     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
 180         (use-package "FOO" "BAZ")
 181       (is restartedp)
 182       (is (equal (list (sym "BAZ" "SYM") :internal)
 183                  (multiple-value-list (sym "BAZ" "SYM")))))))
 184
 185 (with-test (:name :use-package-conflict-set :fails-on :sbcl)
 186   (with-packages (("FOO" (:export "SYM"))
 187                   ("QUX" (:export "SYM"))
 188                   ("BAR" (:intern "SYM"))
 189                   ("BAZ" (:use) (:import-from "BAR" "SYM")))
 190     (let ((conflict-set))
 191       (block nil
 192         (handler-bind
 193             ((sb-ext:name-conflict
 194               (lambda (condition)
 195                 (setf conflict-set (copy-list
 196                                     (sb-ext:name-conflict-symbols condition)))
 197                 (return))))
 198           (use-package '("FOO" "QUX") "BAZ")))
 199       (setf conflict-set
 200             (sort conflict-set #'string<
 201                   :key (lambda (symbol)
 202                          (package-name (symbol-package symbol)))))
 203       (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM"))
 204                  conflict-set)))))
 205
 206 ;;; EXPORT
 207 (with-test (:name :export.1)
 208   (with-packages (("FOO" (:intern "SYM"))
 209                   ("BAR" (:export "SYM"))
 210                   ("BAZ" (:use "FOO" "BAR")))
 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.1a)
 218   (with-packages (("FOO" (:intern "SYM"))
 219                   ("BAR" (:export "SYM"))
 220                   ("BAZ" (:use "FOO" "BAR")))
 221     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
 222         (export (sym "FOO" "SYM") "FOO")
 223       (is restartedp)
 224       (is (eq (sym "BAR" "SYM")
 225               (sym "BAZ" "SYM"))))))
 226
 227 (with-test (:name :export.ensure-exported)
 228   (with-packages (("FOO" (:intern "SYM"))
 229                   ("BAR" (:export "SYM"))
 230                   ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM")))
 231     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 232         (export (sym "FOO" "SYM") "FOO")
 233       (is restartedp)
 234       (is (equal (list (sym "FOO" "SYM") :external)
 235                  (multiple-value-list (sym "FOO" "SYM"))))
 236       (is (eq (sym "FOO" "SYM")
 237               (sym "BAZ" "SYM"))))))
 238
 239 (with-test (:name :export.3.intern)
 240   (with-packages (("FOO" (:intern "SYM"))
 241                   ("BAZ" (:use "FOO") (:intern "SYM")))
 242     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 243         (export (sym "FOO" "SYM") "FOO")
 244       (is restartedp)
 245       (is (eq (sym "FOO" "SYM")
 246               (sym "BAZ" "SYM"))))))
 247
 248 (with-test (:name :export.3a.intern)
 249   (with-packages (("FOO" (:intern "SYM"))
 250                   ("BAZ" (:use "FOO") (:intern "SYM")))
 251     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
 252         (export (sym "FOO" "SYM") "FOO")
 253       (is restartedp)
 254       (is (equal (list (sym "BAZ" "SYM") :internal)
 255                  (multiple-value-list (sym "BAZ" "SYM")))))))
 256
 257 ;;; IMPORT
 258 (with-test (:name :import-nil.1)
 259   (with-packages (("FOO" (:use) (:intern "NIL"))
 260                   ("BAZ" (:use) (:intern "NIL")))
 261     (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp)
 262         (import (list (sym "FOO" "NIL")) "BAZ")
 263       (is restartedp)
 264       (is (eq (sym "FOO" "NIL")
 265               (sym "BAZ" "NIL"))))))
 266
 267 (with-test (:name :import-nil.2)
 268   (with-packages (("BAZ" (:use) (:intern "NIL")))
 269     (with-name-conflict-resolution ('CL:NIL :restarted restartedp)
 270         (import '(CL:NIL) "BAZ")
 271       (is restartedp)
 272       (is (eq 'CL:NIL
 273               (sym "BAZ" "NIL"))))))
 274
 275 (with-test (:name :import-single-conflict :fails-on :sbcl)
 276   (with-packages (("FOO" (:export "NIL"))
 277                   ("BAR" (:export "NIL"))
 278                   ("BAZ" (:use)))
 279     (let ((conflict-sets '()))
 280       (handler-bind
 281           ((sb-ext:name-conflict
 282             (lambda (condition)
 283               (push (copy-list (sb-ext:name-conflict-symbols condition))
 284                     conflict-sets)
 285               (invoke-restart 'sb-ext:resolve-conflict 'CL:NIL))))
 286         (import (list 'CL:NIL (sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ"))
 287       (is (eql 1 (length conflict-sets)))
 288       (is (eql 3 (length (first conflict-sets)))))))
 289
 290 ;;; Make sure that resolving a name-conflict in IMPORT doesn't leave
 291 ;;; multiple symbols of the same name in the package (this particular
 292 ;;; scenario found in 1.0.38.9, but clearly a longstanding issue).
 293 (with-test (:name :import-conflict-resolution)
 294   (with-packages (("FOO" (:export "NIL"))
 295                   ("BAR" (:use)))
 296     (with-name-conflict-resolution ((sym "FOO" "NIL"))
 297       (import (list 'CL:NIL (sym "FOO" "NIL")) "BAR"))
 298     (do-symbols (sym "BAR")
 299       (assert (eq sym (sym "FOO" "NIL"))))))
 300
 301 ;;; UNINTERN
 302 (with-test (:name :unintern.1)
 303   (with-packages (("FOO" (:export "SYM"))
 304                   ("BAR" (:export "SYM"))
 305                   ("BAZ" (:use "FOO" "BAR") (:shadow "SYM")))
 306     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 307         (unintern (sym "BAZ" "SYM") "BAZ")
 308       (is restartedp)
 309       (is (eq (sym "FOO" "SYM")
 310               (sym "BAZ" "SYM"))))))
 311
 312 (with-test (:name :unintern.2)
 313   (with-packages (("FOO" (:intern "SYM")))
 314     (unintern :sym "FOO")
 315     (assert (find-symbol "SYM" "FOO"))))
 316
 317 ;;; WITH-PACKAGE-ITERATOR error signalling had problems
 318 (with-test (:name :with-package-iterator.error)
 319   (assert (eq :good
 320               (handler-case
 321                   (progn
 322                     (eval '(with-package-iterator (sym :cl-user :foo)
 323                             (sym)))
 324                     :bad)
 325                 ((and simple-condition program-error) (c)
 326                   (assert (equal (list :foo) (simple-condition-format-arguments c)))
 327                   :good)))))
 328
 329 ;; X3J13 writeup HASH-TABLE-PACKAGE-GENERATORS says
 330 ;;  "An argument of NIL is treated as an empty list of packages."
 331 ;; This used to fail with "NIL does not name a package"
 332 (with-test (:name :with-package-iterator-nil-list)
 333   (with-package-iterator (iter '() :internal)
 334     (assert (null (iter)))))
 335
 336 ;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
 337 (with-test (:name :bug-511072 :skipped-on (not :sb-thread))
 338   (let* ((p (make-package :bug-511072))
 339          (sem1 (sb-thread:make-semaphore))
 340          (sem2 (sb-thread:make-semaphore))
 341          (t2 (make-join-thread (lambda ()
 342                                  (handler-bind ((error (lambda (c)
 343                                                          (sb-thread:signal-semaphore sem1)
 344                                                          (sb-thread:wait-on-semaphore sem2)
 345                                                          (abort c))))
 346                                    (make-package :bug-511072))))))
 347     (declare (ignore p t2))
 348     (sb-thread:wait-on-semaphore sem1)
 349     (with-timeout 10
 350       (assert (eq 'cons (read-from-string "CL:CONS"))))
 351     (sb-thread:signal-semaphore sem2)))
 352
 353 (defmacro handling ((condition restart-name) form)
 354   `(handler-bind ((,condition (lambda (c)
 355                                 (declare (ignore c))
 356                                 (invoke-restart ',restart-name))))
 357      ,form))
 358
 359
 360 (with-test (:name :quick-name-conflict-resolution-import)
 361   (let (p1 p2)
 362     (unwind-protect
 363          (progn
 364            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1")
 365                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2"))
 366            (intern "FOO" p1)
 367            (handling (name-conflict sb-impl::dont-import-it)
 368              (import (intern "FOO" p2) p1))
 369            (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
 370            (handling (name-conflict sb-impl::shadowing-import-it)
 371              (import (intern "FOO" p2) p1))
 372            (assert (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.1)
 377   (let (p1 p2)
 378     (unwind-protect
 379          (progn
 380            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a")
 381                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a"))
 382            (intern "FOO" p1)
 383            (use-package p2 p1)
 384            (handling (name-conflict sb-impl::keep-old)
 385              (export (intern "FOO" p2) p2))
 386            (assert (not (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-export.2)
 391   (let (p1 p2)
 392     (unwind-protect
 393          (progn
 394            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b")
 395                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b"))
 396            (intern "FOO" p1)
 397            (use-package p2 p1)
 398            (handling (name-conflict sb-impl::take-new)
 399              (export (intern "FOO" p2) p2))
 400            (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
 401       (when p1 (delete-package p1))
 402       (when p2 (delete-package p2)))))
 403
 404 (with-test (:name :quick-name-conflict-resolution-use-package.1)
 405   (let (p1 p2)
 406     (unwind-protect
 407          (progn
 408            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a")
 409                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a"))
 410            (intern "FOO" p1)
 411            (intern "BAR" p1)
 412            (export (intern "FOO" p2) p2)
 413            (export (intern "BAR" p2) p2)
 414            (handling (name-conflict sb-impl::keep-old)
 415              (use-package p2 p1))
 416            (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
 417            (assert (not (eq (intern "BAR" p1) (intern "BAR" p2)))))
 418       (when p1 (delete-package p1))
 419       (when p2 (delete-package p2)))))
 420
 421 (with-test (:name :quick-name-conflict-resolution-use-package.2)
 422   (let (p1 p2)
 423     (unwind-protect
 424          (progn
 425            (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b")
 426                  p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b"))
 427            (intern "FOO" p1)
 428            (intern "BAR" p1)
 429            (export (intern "FOO" p2) p2)
 430            (export (intern "BAR" p2) p2)
 431            (handling (name-conflict sb-impl::take-new)
 432              (use-package p2 p1))
 433            (assert (eq (intern "FOO" p1) (intern "FOO" p2)))
 434            (assert (eq (intern "BAR" p1) (intern "BAR" p2))))
 435       (when p1 (delete-package p1))
 436       (when p2 (delete-package p2)))))
 437
 438 (with-test (:name (:package-at-variance-restarts :shadow))
 439   (let ((p nil)
 440         (*on-package-variance* '(:error t)))
 441     (unwind-protect
 442          (progn
 443            (setf p (eval `(defpackage :package-at-variance-restarts.1
 444                             (:use :cl)
 445                             (:shadow "CONS"))))
 446            (handling (sb-kernel::package-at-variance-error sb-impl::keep-them)
 447              (eval `(defpackage :package-at-variance-restarts.1
 448                       (:use :cl))))
 449            (assert (not (eq 'cl:cons (intern "CONS" p))))
 450            (handling (sb-kernel::package-at-variance-error sb-impl::drop-them)
 451              (eval `(defpackage :package-at-variance-restarts.1
 452                       (:use :cl))))
 453            (assert (eq 'cl:cons (intern "CONS" p))))
 454       (when p (delete-package p)))))
 455
 456 (with-test (:name (:package-at-variance-restarts :use))
 457   (let ((p nil)
 458         (*on-package-variance* '(:error t)))
 459     (unwind-protect
 460          (progn
 461            (setf p (eval `(defpackage :package-at-variance-restarts.2
 462                             (:use :cl))))
 463            (handling (sb-kernel::package-at-variance-error sb-impl::keep-them)
 464              (eval `(defpackage :package-at-variance-restarts.2
 465                       (:use))))
 466            (assert (eq 'cl:cons (intern "CONS" p)))
 467            (handling (sb-kernel::package-at-variance-error sb-impl::drop-them)
 468              (eval `(defpackage :package-at-variance-restarts.2
 469                       (:use))))
 470            (assert (not (eq 'cl:cons (intern "CONS" p)))))
 471       (when p (delete-package p)))))
 472
 473 (with-test (:name (:package-at-variance-restarts :export))
 474   (let ((p nil)
 475         (*on-package-variance* '(:error t)))
 476     (unwind-protect
 477          (progn
 478            (setf p (eval `(defpackage :package-at-variance-restarts.4
 479                             (:export "FOO"))))
 480            (handling (sb-kernel::package-at-variance-error sb-impl::keep-them)
 481              (eval `(defpackage :package-at-variance-restarts.4)))
 482            (assert (eq :external (nth-value 1 (find-symbol "FOO" p))))
 483            (handling (sb-kernel::package-at-variance-error sb-impl::drop-them)
 484              (eval `(defpackage :package-at-variance-restarts.4)))
 485            (assert (eq :internal (nth-value 1 (find-symbol "FOO" p)))))
 486       (when p (delete-package p)))))
 487
 488 (with-test (:name (:package-at-variance-restarts :implement))
 489   (let ((p nil)
 490         (*on-package-variance* '(:error t)))
 491     (unwind-protect
 492          (progn
 493            (setf p (eval `(defpackage :package-at-variance-restarts.5
 494                             (:implement :sb-int))))
 495            (handling (sb-kernel::package-at-variance-error sb-impl::keep-them)
 496              (eval `(defpackage :package-at-variance-restarts.5)))
 497            (assert (member p (package-implemented-by-list :sb-int)))
 498            (handling (sb-kernel::package-at-variance-error sb-impl::drop-them)
 499              (eval `(defpackage :package-at-variance-restarts.5)))
 500            (assert (not (member p (package-implemented-by-list :sb-int)))))
 501       (when p (delete-package p)))))
 502
 503 (with-test (:name (:delete-package :implementation-package))
 504   (let (p1 p2)
 505     (unwind-protect
 506          (progn
 507            (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1")
 508                  p2 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2"))
 509            (add-implementation-package p2 p1)
 510            (assert (= 1 (length (package-implemented-by-list p1))))
 511            (delete-package p2)
 512            (assert (= 0 (length (package-implemented-by-list p1)))))
 513       (when p1 (delete-package p1))
 514       (when p2 (delete-package p2)))))
 515
 516 (with-test (:name (:delete-package :implementated-package))
 517   (let (p1 p2)
 518     (unwind-protect
 519          (progn
 520            (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1")
 521                  p2 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2"))
 522            (add-implementation-package p2 p1)
 523            (assert (= 1 (length (package-implements-list p2))))
 524            (delete-package p1)
 525            (assert (= 0 (length (package-implements-list p2)))))
 526       (when p1 (delete-package p1))
 527       (when p2 (delete-package p2)))))
 528
 529 (with-test (:name :package-local-nicknames)
 530   ;; Clear slate
 531   (without-package-locks
 532     (when (find-package :package-local-nicknames-test-1)
 533       (delete-package :package-local-nicknames-test-1))
 534     (when (find-package :package-local-nicknames-test-2)
 535       (delete-package :package-local-nicknames-test-2)))
 536   (eval `(defpackage :package-local-nicknames-test-1
 537            (:local-nicknames (:l :cl) (:sb :sb-ext))))
 538   (eval `(defpackage :package-local-nicknames-test-2
 539            (:export "CONS")))
 540   ;; Introspection
 541   (let ((alist (package-local-nicknames :package-local-nicknames-test-1)))
 542     (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=)))
 543     (assert (equal (cons "SB" (find-package "SB-EXT")) (assoc "SB" alist :test 'string=)))
 544     (assert (eql 2 (length alist))))
 545   ;; Usage
 546   (let ((*package* (find-package :package-local-nicknames-test-1)))
 547     (let ((cons0 (read-from-string "L:CONS"))
 548           (exit0 (read-from-string "SB:EXIT"))
 549           (cons1 (find-symbol "CONS" :l))
 550           (exit1 (find-symbol "EXIT" :sb))
 551           (cl (find-package :l))
 552           (sb (find-package :sb)))
 553       (assert (eq 'cons cons0))
 554       (assert (eq 'cons cons1))
 555       (assert (equal "L:CONS" (prin1-to-string cons0)))
 556       (assert (eq 'sb-ext:exit exit0))
 557       (assert (eq 'sb-ext:exit exit1))
 558       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 559       (assert (eq cl (find-package :common-lisp)))
 560       (assert (eq sb (find-package :sb-ext)))))
 561   ;; Can't add same name twice for different global names.
 562   (assert (eq :oopsie
 563               (handler-case
 564                   (add-package-local-nickname :l :package-local-nicknames-test-2
 565                                               :package-local-nicknames-test-1)
 566                 (error ()
 567                   :oopsie))))
 568   ;; But same name twice is OK.
 569   (add-package-local-nickname :l :cl :package-local-nicknames-test-1)
 570   ;; Removal.
 571   (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
 572   (let ((*package* (find-package :package-local-nicknames-test-1)))
 573     (let ((exit0 (read-from-string "SB:EXIT"))
 574           (exit1 (find-symbol "EXIT" :sb))
 575           (sb (find-package :sb)))
 576       (assert (eq 'sb-ext:exit exit0))
 577       (assert (eq 'sb-ext:exit exit1))
 578       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 579       (assert (eq sb (find-package :sb-ext)))
 580       (assert (not (find-package :l)))))
 581   ;; Adding back as another package.
 582   (assert (eq (find-package :package-local-nicknames-test-1)
 583               (add-package-local-nickname :l :package-local-nicknames-test-2
 584                                           :package-local-nicknames-test-1)))
 585   (let ((*package* (find-package :package-local-nicknames-test-1)))
 586     (let ((cons0 (read-from-string "L:CONS"))
 587           (exit0 (read-from-string "SB:EXIT"))
 588           (cons1 (find-symbol "CONS" :l))
 589           (exit1 (find-symbol "EXIT" :sb))
 590           (cl (find-package :l))
 591           (sb (find-package :sb)))
 592       (assert (eq cons0 cons1))
 593       (assert (not (eq 'cons cons0)))
 594       (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2)
 595                   cons0))
 596       (assert (equal "L:CONS" (prin1-to-string cons0)))
 597       (assert (eq 'sb-ext:exit exit0))
 598       (assert (eq 'sb-ext:exit exit1))
 599       (assert (equal "SB:EXIT" (prin1-to-string exit0)))
 600       (assert (eq cl (find-package :package-local-nicknames-test-2)))
 601       (assert (eq sb (find-package :sb-ext)))))
 602   ;; Interaction with package locks.
 603   (lock-package :package-local-nicknames-test-1)
 604   (assert (eq :package-oopsie
 605               (handler-case
 606                   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
 607                 (package-lock-violation ()
 608                   :package-oopsie))))
 609   (assert (eq :package-oopsie
 610               (handler-case
 611                   (remove-package-local-nickname :l :package-local-nicknames-test-1)
 612                 (package-lock-violation ()
 613                   :package-oopsie))))
 614   (unlock-package :package-local-nicknames-test-1)
 615   (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
 616   (remove-package-local-nickname :l :package-local-nicknames-test-1))
 617
 618 (defmacro with-tmp-packages (bindings &body body)
 619   `(let ,(mapcar #'car bindings)
 620      (unwind-protect
 621           (progn
 622             (setf ,@(apply #'append bindings))
 623             ,@body)
 624        ,@(mapcar (lambda (p)
 625                    `(when ,p (delete-package ,p)))
 626                  (mapcar #'car bindings)))))
 627
 628 (with-test (:name (:delete-package :locally-nicknames-others))
 629   (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
 630                       (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
 631     (add-package-local-nickname :foo p2 p1)
 632     (assert (equal (list p1) (package-locally-nicknamed-by-list p2)))
 633     (delete-package p1)
 634     (assert (not (package-locally-nicknamed-by-list p2)))))
 635
 636 (with-test (:name (:delete-package :locally-nicknamed-by-others))
 637   (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
 638                       (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
 639     (add-package-local-nickname :foo p2 p1)
 640     (assert (package-local-nicknames p1))
 641     (delete-package p2)
 642     (assert (not (package-local-nicknames p1)))))
 643
 644 (with-test (:name :own-name-as-local-nickname)
 645   (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
 646                       (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
 647     (assert (eq :oops
 648                 (handler-case
 649                     (add-package-local-nickname :own-name-as-nickname1 p2 p1)
 650                   (error ()
 651                     :oops))))
 652     (handler-bind ((error #'continue))
 653       (add-package-local-nickname :own-name-as-nickname1 p2 p1))
 654     (assert (eq (intern "FOO" p2)
 655                 (let ((*package* p1))
 656                   (intern "FOO" :own-name-as-nickname1))))))
 657
 658 (with-test (:name :own-nickname-as-local-nickname)
 659   (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
 660                                         :nicknames '("OWN-NICKNAME")))
 661                       (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
 662     (assert (eq :oops
 663                 (handler-case
 664                     (add-package-local-nickname :own-nickname p2 p1)
 665                   (error ()
 666                     :oops))))
 667     (handler-bind ((error #'continue))
 668       (add-package-local-nickname :own-nickname p2 p1))
 669     (assert (eq (intern "FOO" p2)
 670                 (let ((*package* p1))
 671                   (intern "FOO" :own-nickname))))))
 672
 673 (defun random-package-name (min max)
 674   (let* ((s (make-string (+ min (random (- max min))))))
 675     (dotimes (i (length s) s)
 676       (setf (char s i) (code-char (+ (char-code #\A) (random 26)))))))
 677
 678 ;;; Hammer on the somewhat intricate structure that maintains the bidirection mapping
 679 ;;; between PLNs and packages, and PLN ID to package.
 680 (with-test (:name :pln-data-structure-bashing)
 681   (with-tmp-packages ((referencing-pkg (make-package "FOO")))
 682     (prog (plns)
 683        (dotimes (i 40)
 684          (let ((package (make-package (random-package-name 10 12)))
 685                (local-nick (random-package-name 3 6)))
 686            (push (cons local-nick package) plns)
 687            (add-package-local-nickname local-nick package referencing-pkg)))
 688        iterate
 689        ;; Test all 3 directions of the mapping
 690        (dolist (entry plns)
 691          ;; local nickname to package
 692          (assert (eq (sb-impl::pkgnick-search-by-name (car entry) referencing-pkg)
 693                      (cdr entry)))
 694          ;; numeric id to package
 695          (let ((id (sb-int:info-gethash (car entry) (car sb-impl::*package-nickname-ids*))))
 696            (assert (eq (sb-impl::pkgnick-search-by-id id referencing-pkg)
 697                        (cdr entry))))
 698          ;; package to local nickname
 699          (assert (string= (sb-impl::package-local-nickname (cdr entry)
 700                                                            referencing-pkg)
 701                           (car entry))))
 702        ;; Delete a random package that has a local nickname
 703        (let ((entry (nth (random (length plns)) plns)))
 704          (delete-package (cdr entry))
 705          ;; Deletion removes from local nicknames on attempted lookup
 706          (assert (not (sb-impl::find-package-using-package (car entry) referencing-pkg)))
 707          (setq plns (delete entry plns))
 708          (assert (= (length (car (sb-impl::package-%local-nicknames referencing-pkg)))
 709                     (* 2 (length plns)))))
 710        (when plns (go iterate)))))
 711
 712 (defun intern-in-fixed-pkg-designator (x) (intern x "PWELN"))
 713 (compile 'intern-in-fixed-pkg-designator)
 714
 715 (with-test (:name :cached-find-package)
 716   (with-tmp-packages
 717       ((p1 (make-package "PKG-WITH-EXCEEDINGLY-LONG-NAME"))
 718        (p2 (make-package "PKG-WHICH-EVERYONE-LOVES-NOW" :nicknames '("PWELN")))
 719        (p3 (defpackage "USERPKG"
 720              (:local-nicknames ("PWELN" "PKG-WITH-EXCEEDINGLY-LONG-NAME")
 721                                ("FOOCL" "COMMON-LISP")))))
 722       (let ((s (intern-in-fixed-pkg-designator "A")))
 723         (assert (eq (symbol-package s) p2))) ; global PWELN package
 724       (let ((s (let ((*package* p3))
 725                  (intern-in-fixed-pkg-designator "A"))))
 726         (assert (eq (symbol-package s) p1))) ; local PWELN package
 727       (delete-package p1) ; will lazily delete "inbound" nicknames
 728       (let ((s (let ((*package* p3))
 729                  (intern-in-fixed-pkg-designator "A"))))
 730         (assert (eq (symbol-package s) p2))))) ; global PWELN package
 731
 732 (with-test (:name :delete-package-restart)
 733   (let* (ok
 734          (result
 735            (handler-bind
 736                ((sb-kernel:simple-package-error
 737                   (lambda (c)
 738                     (setf ok t)
 739                     (continue c))))
 740              (delete-package (gensym)))))
 741     (assert ok)
 742     (assert (not result))))
 743
 744 ;; WITH-PACKAGE-ITERATOR isn't well-exercised by tests (though LOOP uses it)
 745 ;; so here's a basic correctness test with some complications involving
 746 ;; shadowing symbols.
 747 (make-package "FOOFORMAT" :use '("CL"))
 748 (export 'fooformat::format-error 'fooformat)
 749 (export 'fooformat::%compiler-walk-format-string 'fooformat)
 750 (make-package "P1" :use '("FOOFORMAT"))
 751 (make-package "P2")
 752 (export 'p1::foo 'p1)
 753 (shadow "FORMAT-ERROR" 'p1)
 754 (make-package "A" :use '("FOOFORMAT" "P1" "P2"))
 755 (shadow '("PROG2" "FOO") 'a)
 756 (intern "BLAH" "P2")
 757 (export 'p2::(foo bar baz) 'p2)
 758 (export 'a::goodfun 'a)
 759
 760 (with-test (:name :with-package-iterator)
 761   (let ((tests '((:internal) (:external) (:inherited)
 762                  (:internal :inherited)
 763                  (:internal :external)
 764                  (:external :inherited)
 765                  (:internal :external :inherited)))
 766         (maximum-answer
 767          '(;; symbols visible in A
 768            (a::prog2 :internal "A")
 769            (a::foo :internal "A")
 770            (a:goodfun :external "A")
 771            (p2:bar :inherited "A")
 772            (p2:baz :inherited "A")
 773            (fooformat:%compiler-walk-format-string :inherited "A")
 774            (fooformat:format-error :inherited "A")
 775            ;; ... P1
 776            (p1:foo :external "P1")
 777            (p1::format-error :internal "P1")
 778            (fooformat:%compiler-walk-format-string :inherited "P1")
 779            ;; ... P2
 780            (p2::blah :internal "P2")
 781            (p2:foo :external "P2")
 782            (p2:bar :external "P2")
 783            (p2:baz :external "P2"))))
 784     ;; Compile a new function to test each combination of
 785     ;; accessibility-kind since the macro doesn't eval them.
 786     (dolist (access tests)
 787       ; (print `(testing ,access))
 788       (let ((f (compile
 789                 nil
 790                 `(lambda ()
 791                    (with-package-iterator (iter '(p1 a p2) ,@access)
 792                      (let (res)
 793                        (loop
 794                         (multiple-value-bind (foundp sym access pkg) (iter)
 795                           (if foundp
 796                               (push (list sym access (package-name pkg)) res)
 797                               (return))))
 798                        res))))))
 799         (let ((answer (funcall f))
 800               (expect (remove-if-not (lambda (x) (member (second x) access))
 801                                      maximum-answer)))
 802           ;; exactly as many results as expected
 803           (assert (equal (length answer) (length expect)))
 804           ;; each result is right
 805           (assert (equal (length (intersection answer expect :test #'equal))
 806                          (length expect))))))))
 807
 808 ;; Assert that changes in size of a symbo-hashset's symbol vector
 809 ;; do not cause WITH-PACKAGE-ITERATOR to crash. The vector shouldn't grow,
 810 ;; because it is not permitted to INTERN new symbols, but it can shrink
 811 ;; because it is expressly permitted to UNINTERN the current symbol.
 812 ;; (In fact we allow INTERN, but that's beside the point)
 813 (with-test (:name :with-package-iterator-and-mutation)
 814   (flet ((table-size (pkg)
 815            (length (sb-impl::symtbl-cells
 816                     (sb-impl::package-internal-symbols pkg)))))
 817     (let* ((p (make-package (string (gensym))))
 818            (initial-table-size (table-size p))
 819            (strings
 820             '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m")))
 821       (dolist (x strings)
 822         (intern x p))
 823       (let ((grown-table-size (table-size p)))
 824         (assert (> grown-table-size initial-table-size))
 825         (let ((n 0))
 826           (with-package-iterator (iter p :internal)
 827             (loop (multiple-value-bind (foundp sym) (iter)
 828                     (cond (foundp
 829                            (incf n)
 830                            (unintern sym p))
 831                           (t
 832                            (return)))))
 833             (assert (= n (length strings)))
 834             ;; while we're at it, assert that calling the iterator
 835             ;; a couple more times returns nothing.
 836             (dotimes (i 2)
 837               (assert (not (iter))))))
 838         (let ((shrunk-table-size (table-size p)))
 839           (assert (< shrunk-table-size grown-table-size)))))))
 840
 841 (with-test (:name :symbol-externalp)
 842   (with-package-iterator (iter (list-all-packages) :internal :external)
 843     (loop
 844         (multiple-value-bind (foundp sym access pkg) (iter)
 845           (unless foundp (return))
 846           (when (eq access :external)
 847             (assert (sb-impl::symbol-externalp sym pkg)))))))
 848
 849 ;; example from CLHS
 850 (with-test (:name :do-symbols-block-scope)
 851   (assert (eq t
 852               (block nil
 853                 (do-symbols (s (or (find-package "FROB") (return nil)))
 854                   (print s))
 855                 t))))
 856
 857 (with-test (:name :export-inaccessible-lookalike)
 858   (make-package "E1")
 859   (make-package "E2")
 860   (export (intern "A" "E2") 'e2)
 861   (multiple-value-bind (answer condition)
 862       (ignore-errors  (export (intern "A" "E1") 'e2))
 863     (assert (and (not answer)
 864                  (and (typep condition 'sb-kernel:simple-package-error)
 865                       (search "not accessible"
 866                               (simple-condition-format-control condition)))))))
 867
 868 ;; Concurrent FIND-SYMBOL was adversely affected by package rehash.
 869 ;; It's slightly difficult to show that this is fixed, because this
 870 ;; test only sometimes failed prior to the fix. Now it never fails though.
 871 (with-test (:name :concurrent-find-symbol :skipped-on (not :sb-thread))
 872  (let ((pkg (make-package (gensym)))
 873        (threads)
 874        (names)
 875        (run nil))
 876    (dotimes (i 50)
 877      (let ((s (string (gensym "FRED"))))
 878        (push s names)
 879        (intern s pkg)))
 880    (dotimes (i 5)
 881      (push (sb-thread:make-thread
 882             (lambda ()
 883               (wait-for run)
 884               (let ((n-missing 0))
 885                 (dotimes (i 10 n-missing)
 886                   (dolist (name names)
 887                     (unless (find-symbol name pkg)
 888                       (incf n-missing)))))))
 889            threads))
 890    (setq run t)
 891    ;; Interning new symbols can't cause the pre-determined
 892    ;; 50 names to transiently disappear.
 893    (let ((s (make-string 3))
 894          (alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZ012345"))
 895      (dotimes (i (expt 32 3))
 896        (setf (char s 0) (char alphabet (ldb (byte 5 10) i))
 897              (char s 1) (char alphabet (ldb (byte 5  5) i))
 898              (char s 2) (char alphabet (ldb (byte 5  0) i)))
 899        (intern s pkg)))
 900    (let ((tot-missing 0))
 901      (dolist (thread threads (assert (zerop tot-missing)))
 902        (incf tot-missing (sb-thread:join-thread thread))))))
 903
 904 (with-test (:name :defpackage-multiple-nicknames)
 905   (let* ((name1 (string (gensym)))
 906          (name2 (string (gensym)))
 907          (names (package-nicknames
 908                  (eval `(defpackage ,(gensym)
 909                           (:nicknames ,name1)
 910                           (:nicknames ,name2))))))
 911     (assert (or (equal
 912                  names
 913                  (list name1 name2))
 914                 (equal
 915                  names
 916                  (list name2 name1))))))
 917
 918 (with-test (:name (defpackage :local-nicknames :lock))
 919   (destructuring-bind (name1 name2 name3)
 920       (loop :repeat 3 :collect (string (gensym)))
 921     (let ((package1 (eval `(defpackage ,name1)))
 922           (package2 (eval `(defpackage ,name2
 923                              (:local-nicknames (,name3 ,name1))
 924                              (:lock t)))))
 925       (assert (equal (package-local-nicknames package2) `((,name3 . ,package1))))
 926       (assert (package-locked-p package2)))))
 927
 928 (with-test (:name :locally-nicknamed-by-dedup)
 929   (with-tmp-packages
 930       ((p1 (make-package "LONGNAME.SAMPLE.FRED"))
 931        (p2 (defpackage "BAZ"
 932              (:local-nicknames (:fred "LONGNAME.SAMPLE.FRED")
 933                                (:f "LONGNAME.SAMPLE.FRED")))))
 934     (assert (equal (package-locally-nicknamed-by-list "LONGNAME.SAMPLE.FRED")
 935                    (list (find-package "BAZ"))))))
 936
 937 ;;; Now a possibly useless test on an essentially useless function.
 938 ;;; But we may as well get it right - assert that GENTEMP returns
 939 ;;; a symbol that definitely did not exist in the specified package
 940 ;;; even if multiple threads are calling it simultaneously.
 941
 942 ;;; We'll create about 25000 symbols, and mark the ones that were returned
 943 ;;; by GENTEMP. Because *GENTEMP-COUNTER* isn't synchronized, but INTERN is,
 944 ;;; returning an indicator of whether it created a symbol, it's simple enough
 945 ;;; to make GENTEMP not accidentally return a symbol created by someone else.
 946
 947 ;;; Use array of fixnums because there're no atomic ops on array of word.
 948 ;;; This is either 58000 useful bits or 126000 bits depending on word size.
 949 (defglobal *scoreboard* (make-array 2000 :initial-element 0))
 950 (defglobal *testpkg* (make-package "A-NICE-PACKAGE"))
 951
 952 (defun hammer-on-gentemp (package n-iter)
 953   (dotimes (i n-iter)
 954     (let ((index (parse-integer (string (gentemp "T" package)) :start 1)))
 955       ;; Mark this index in the scoreboard, failing if already set.
 956       (multiple-value-bind (elt-index bit-index)
 957           (floor index sb-vm:n-positive-fixnum-bits)
 958         (let ((old (svref *scoreboard* elt-index)))
 959           (loop
 960            (when (logbitp bit-index old) (return-from hammer-on-gentemp :fail))
 961            (let ((actual-old
 962                   (cas (svref *scoreboard* elt-index)
 963                        old (logior old (ash 1 bit-index)))))
 964              (if (eq old actual-old) (return))
 965              (setq old actual-old))))))))
 966
 967 ;; This test would consistently fail when GENTEMP first called FIND-SYMBOL
 968 ;; and then INTERN when FIND-SYMBOL said that it found no symbol.
 969 (with-test (:name (gentemp :threadsafety) :skipped-on (not :sb-thread))
 970   (let ((n-threads 5)
 971         (n-iter 1000)
 972         (threads))
 973     (dotimes (i n-threads)
 974       (push (sb-thread:make-thread #'hammer-on-gentemp
 975                                    :arguments (list *testpkg* n-iter))
 976             threads))
 977     (let ((results (mapcar #'sb-thread:join-thread threads)))
 978       (assert (not (find :fail results))))))
 979
 980 ;;; This test is a bit weak in that prior to the fix for what it tests,
 981 ;;; it didn't fail often enough to convincingly show that there was a problem.
 982 ;;; Nonetheless it did sometimes fail, and now should never fail.
 983 (with-test (:name :concurrent-intern-bad-published-symbol-package
 984                   ;; No point in wasting time on concurrency bugs otherwise
 985                   :skipped-on (not :sb-thread))
 986   ;; Confirm that the compiler does not know that KEYWORDICATE
 987   ;; returns a KEYWORD (so the answer isn't constant-folded)
 988   (assert (sb-kernel:type= (sb-int:info :function :type 'sb-int:keywordicate)
 989                            (sb-kernel:find-classoid 'function)))
 990   (let ((sema (sb-thread:make-semaphore))
 991         (n-threads 10))
 992     (dotimes (i 10) ; number of trials
 993       (let ((threads))
 994         (dotimes (i n-threads)
 995           (push (make-join-thread
 996                  (lambda ()
 997                    (sb-thread:wait-on-semaphore sema)
 998                    (keywordp (sb-int:keywordicate "BLUB"))))
 999                 threads))
1000         (sb-thread:signal-semaphore sema n-threads)
1001         (let ((count 0))
1002           (dolist (thread threads)
1003             (when (sb-thread:join-thread thread) (incf count)))
1004           (unintern (sb-int:keywordicate "BLUB") "KEYWORD")
1005           (assert (= count n-threads)))))))
1006
1007 (with-test (:name :name-conflict-non-pretty-message)
1008   (make-package "SILLYPACKAGE1")
1009   (export (intern "ASILLYSYM" 'sillypackage1) 'sillypackage1)
1010   (make-package "SILLYPACKAGE2")
1011   (export (intern "ASILLYSYM" 'sillypackage2) 'sillypackage2)
1012   (use-package 'sillypackage1)
1013   (handler-case (use-package 'sillypackage2)
1014     (name-conflict (c) ; No silly string in the result
1015       (assert (not (search "symbols:SILLY"
1016                            (write-to-string c :pretty nil :escape nil)))))
1017     (condition () (error "Should not get here"))
1018     (:no-error (c) (declare (ignore c)) (error "Should not get here"))))
1019
1020 ;; git revision f7d1550c0e16262f28213c9e3c048f42e3f0b476 broke find-all-symbols
1021 (with-test (:name :find-all-symbols)
1022   (find-all-symbols "FIXNUM"))
1023
1024 (defun foo-intern (x) (intern x "PKG-A"))
1025 (compile 'foo-intern)
1026 ;;; Basic smoke test of compiler transform of INTERN
1027 (with-test (:name :cached-find-package)
1028   (assert-error (foo-intern "X"))
1029   (make-package "PKG-A")
1030   (locally (declare (notinline intern find-symbol))
1031     (assert (eq (foo-intern "X") (find-symbol "X" "PKG-A")))
1032     (delete-package "PKG-A")
1033     (make-package "PKG-B" :nicknames '("PKG-A"))
1034     (assert (eq (foo-intern "X") (find-symbol "X" "PKG-B")))))
1035
1036 ;;; The concept behind the intricate storage representation of local nicknames
1037 ;;; was that adding a nickname does not create a strong reference to the
1038 ;;; nicknamed package, but nonetheless avoids having to do a FIND-PACKAGE
1039 ;;; on its actual name. This is efficient, but it is complicated because
1040 ;;; it involves weak objects. Here is a test which asserts that.
1041 ;;; [It probably would have been fine to penalize DELETE-PACKAGE by forcing
1042 ;;; it to scan all other packages for local nicknames of the deleted one,
1043 ;;; but I guess I didn't want to do that. But I wonder if it might be possible
1044 ;;; to reduce the complexity now that we have package IDs.]
1045 (defvar *the-weak-ptr*) ; to determine that the test worked
1046 (defun prepare-nickname-weakness-test ()
1047   (setq *the-weak-ptr* (make-weak-pointer (make-package "SOMEPACKAGE")))
1048   (make-package "MYPKG" :use '("CL"))
1049   (add-package-local-nickname "SP" "SOMEPACKAGE" "MYPKG")
1050   (intern "ZOOK" "SOMEPACKAGE")
1051   (let ((*package* (find-package "MYPKG")))
1052     (assert (eq (find-symbol "ZOOK" "SP")
1053                 (find-symbol "ZOOK" "SOMEPACKAGE")))))
1054
1055 (with-test (:name :local-nicknames-like-weak-pointers)
1056   (prepare-nickname-weakness-test)
1057   ;; Check that SP is a local nickname
1058   (assert (let ((*package* (find-package "MYPKG"))) (find-symbol "ZOOK" "SP")))
1059   ;;; But not a global name of any package
1060   (assert-error (find-symbol "ZOOK" "SP"))
1061   (delete-package "SOMEPACKAGE")
1062   ;; Assert that the local nickname vector has not yet removed the
1063   ;; deleted package. DELETE-PACKAGE does not scan all packages to adjust
1064   ;; their local nicknames. (There's no "locally nicknamed by" accessor so it
1065   ;; definitely would need to visit all packages which I didn't like.
1066   ;; It wouldn't be the worst thing, but I opted not to store a reverse lookup)
1067   ;; Rather interestingly, this operation overwrites a words of the control stack
1068   ;; that might otherwise randomly contain the very package that got deleted.
1069   (assert (= (sb-int:weak-vector-len
1070               (cdr (sb-impl::package-%local-nicknames (find-package "MYPKG"))))
1071              2))
1072   (sb-sys:scrub-control-stack)
1073   (gc :full t)
1074   ;; Asserting that the weak pointer gets splatted _before_ doing the next FIND-SYMBOL
1075   ;; confirms that the nickname representation did not store a strong reference
1076   ;; to #<SOMEPACKAGE>. Package-local nicknames are necessarily purged of any deleted
1077   ;; packages just-in-time, so the assertion would not demonstrate anything if run
1078   ;; _after_ calling FIND-SYMBOL. I don't know why this fails on #+win32, SEARCH-ROOTS
1079   ;; did not return a path, so there must also be a deficiency in that.
1080   #-win32 (assert (not (weak-pointer-value *the-weak-ptr*)))
1081   (assert-error (let ((*package* (find-package "MYPKG")))
1082                   ;; the nickname magically went away!
1083                   (find-symbol "ZOOK" "SP"))))
1084
1085 ;;; This is probably, strictly speaking, non-conforming code according
1086 ;;; to ANSI 3.2.4.4 under item 1 for symbol, taking package "same"ness
1087 ;;; to mean EQness.
1088 (with-test (:name :defpackage-rename-package-redefpackage)
1089   (ctu:file-compile
1090    `((eval-when (:compile-toplevel :load-toplevel :execute)
1091        (when (find-package "DEFPACKAGE4")
1092          (rename-package "DEFPACKAGE4" "DEFPACKAGE4")))
1093      (defpackage "DEFPACKAGE4"
1094        (:use :cl))
1095      (in-package "DEFPACKAGE4")
1096      (eval-when (:compile-toplevel :load-toplevel :execute)
1097        (export '(f))))
1098    :load t)
1099   (assert (eq (nth-value 1 (find-symbol "F" "DEFPACKAGE4"))
1100               :external)))
1101
1102 (with-test (:name :defpackage-rename-package)
1103   (delete-package "BAR")
1104   (ctu:file-compile
1105    `((eval-when (:compile-toplevel :load-toplevel :execute)
1106        (cond
1107          ((find-package "FOO")
1108           (rename-package "FOO"
1109                           "BAR"))
1110          ((not (find-package "BAR"))
1111           (make-package "BAR" :use '("CL")))))
1112
1113      (in-package "BAR")
1114
1115      (defun stable-union (bar) bar))
1116    :before-load (lambda ()
1117                   (delete-package "BAR")
1118                   (defpackage foo (:use :cl)))
1119    :load t)
1120   (assert (find-symbol "STABLE-UNION" "BAR"))
1121   (delete-package "BAR"))
1122
1123 (with-test (:name :defpackage-rename-package-symbol-conflict)
1124   (with-scratch-file (fasl2 "fasl")
1125     (compile-file "package-test-2.lisp" :output-file fasl2)
1126     (delete-package "BAR")
1127     (with-scratch-file (fasl1 "fasl")
1128       (compile-file "package-test-1.lisp" :output-file fasl1)
1129       (load fasl2)))
1130   (assert (eq (symbol-package (find-symbol "BAZ" "BAR"))
1131               (find-package "BAR")))
1132   (assert (eq (funcall (find-symbol "BAZ" "BAR"))
1133               :good))
1134   (delete-package "BAR"))
1135
1136 (with-test (:name :defpackage-rename-package-preserve-externals)
1137   (with-scratch-file (fasl4 "fasl")
1138     (compile-file "package-test-4.lisp" :output-file fasl4)
1139     (delete-package "FOO-NEW")
1140     (with-scratch-file (fasl3 "fasl")
1141       (compile-file "package-test-3.lisp" :output-file fasl3)
1142       (load fasl4)))
1143   (assert (eq (nth-value 1 (find-symbol "BAR" "FOO-NEW"))
1144               :external))
1145   (delete-package "FOO-NEW"))
1146
1147 (with-test (:name :defpackage-delete-package-redefpackage-fasloader)
1148   (with-scratch-file (fasl5 "fasl")
1149     (compile-file "package-test-5.lisp" :output-file fasl5)
1150     (load fasl5)
1151     (if (find-package "BAR-DRRFL") (delete-package "BAR-DRRFL"))
1152     (with-scratch-file (fasl6 "fasl")
1153       (compile-file "package-test-6.lisp" :output-file fasl6)
1154       (load fasl6)
1155       (load fasl6))
1156     (delete-package "BAR-DRRFL")))
1157
1158 ;;; We were not creating fasls correctly when a file defining a
1159 ;;; package was compiled twice, since we were relying on the compile
1160 ;;; time effect of that happening to change the behavior of what code
1161 ;;; to put in the same component.
1162 (with-test (:name :make-package-compile-twice)
1163   (with-scratch-file (fasl7 "fasl")
1164     (compile-file "package-test-7.lisp" :output-file fasl7)
1165     (compile-file "package-test-7.lisp" :output-file fasl7)
1166     (delete-package "COMPILE-TWICE")
1167     (load fasl7)
1168     (delete-package "COMPILE-TWICE")))