tests/package-id.impure.lisp

   1 (import 'sb-impl::*all-packages*)
   2
   3 ;;; Assert that a global name of a package that hashes to the same bucket as a different
   4 ;;; global name of the package does not cause disappearance of the package from
   5 ;;; *ALL-PACKAGES* when only one name is removed. i.e. don't naively blast the item
   6 ;;; out of the bucket corresponding to the hash of the removed name.
   7 ;;; Start by making 4 packages and deleting them so that the table won't resize during
   8 ;;; the addition of nicknames. (It assumes that every name increases the table load)
   9 (mapc 'delete-package (mapcar 'make-package '("AA" "BB" "CC" "DD")))
  10 (defvar *tp* (make-package "SOMETESTPACKAGE"))
  11 (defun compute-name-bucket (str)
  12   (mod (sxhash str) (1- (length *all-packages*))))
  13 (defvar *tp-bucket* (compute-name-bucket "SOMETESTPACKAGE"))
  14
  15 ;;; Generate a random nicknames for SOMETESTPACKAGE that hashes to
  16 ;;; the same bucket.
  17 (defvar *random-names* nil)
  18 (loop for i from 1
  19       do (let ((name (format nil "PKGNAME~36R" i)))
  20            (when (eql (compute-name-bucket name) *tp-bucket*)
  21              (push name *random-names*)
  22              (when (eql (length *random-names*) 3) (loop-finish)))))
  23 (rename-package *tp* (first *random-names*)
  24                 (cons "SOMETESTPACKAGE" (rest *random-names*)))
  25 (defun get-bucket (i) (sb-int:ensure-list (aref *all-packages* i)))
  26 (with-test (:name :package-name-hash-collision)
  27   ;; SOMETESTPACKGE should be in its bucket exactly once for all 4 names
  28   (assert (= (count *tp* (get-bucket *tp-bucket*)) 1))
  29   ;; Remove 2 names, it should still be there exactly once
  30   (rename-package *tp* "SOMETESTPACKAGE" (last *random-names*))
  31   (assert (= (count *tp* (get-bucket *tp-bucket*)) 1)))
  32
  33 ;;; this test is slow
  34
  35 ;;; It's extremely unlikely that a user would make >2^16 packages, but test that it works.
  36 (defun grow-id->package-vector ()
  37   (let ((table (make-array 65535 :initial-element nil))) ; grow once only. Sorry for cheating
  38     (replace table sb-impl:*id->package*)
  39     (setf sb-impl:*id->package* table)))
  40 (compile 'grow-id->package-vector)
  41
  42 (with-test (:name :ridiculous-amount-of-packages)
  43   (make-package "WATPACKAGE")
  44   (grow-id->package-vector) ; grow once only. Sorry for cheating
  45   (loop
  46     ;; This loop unfortunately takes 2 seconds, which kind of speaks to
  47     ;; the slowness of package creation. I don't think we need to improve that,
  48     ;; but we _do_ need to test this, so ... it's a minor point of pain.
  49     ;; Unsurprisingly, 50% of the time is spent in PACKAGE-REGISTRY-UPDATE
  50     (let* ((package (make-package "STRANGE"))
  51            (id (sb-impl::package-id package))
  52            (new-name (format nil "TEST-PKGID-~D" id)))
  53       (unless id (return))
  54       (rename-package package new-name)))
  55   (let ((p (find-package "STRANGE")))
  56     (assert (not (sb-impl::package-id p)))
  57     (let ((symbol (intern "WAT123" p)))
  58       (assert (eq (symbol-package symbol) p))
  59       (delete-package p)
  60       (assert (not (symbol-package symbol)))
  61       (import symbol "WATPACKAGE")
  62       (assert (eq (symbol-package symbol) (find-package "WATPACKAGE")))
  63       ;; assert that the symbol got a small ID
  64       (assert (not (sb-int:info :symbol :package symbol)))))
  65   (delete-package "WATPACKAGE")
  66   (let ((p (make-package "ANOTHERPACKAGE")))
  67     (assert (sb-impl::package-id p)))
  68   (let ((p (make-package "YETANOTHERPACKAGE")))
  69     (assert (not (sb-impl::package-id p))))
  70   ;; Now for every package named TEST-PKGIDnm, check that a symbol interned
  71   ;; in that package can read the bits back correctly (because vops are confusing)
  72   (let ((n 0))
  73     (dolist (package (list-all-packages))
  74       (when (search "TEST-PKGID-" (package-name package))
  75         (incf n)
  76         (let ((the-symbol (intern "FROBOLA" package)))
  77           (assert (eq (symbol-package the-symbol) package)))))
  78     (assert (> n 65450)))) ; assert that we exercised lots of bit patterns