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 (make-package "FOO")
  15 (defvar *foo* (find-package (coerce "FOO" 'base-string)))
  16 (rename-package "FOO" (make-array 0 :element-type nil))
  17 (assert (eq *foo* (find-package "")))
  18 (assert (delete-package ""))
  19
  20 (make-package "BAR")
  21 (defvar *baz* (rename-package "BAR" "BAZ"))
  22 (assert (eq *baz* (find-package "BAZ")))
  23 (assert (delete-package *baz*))
  24
  25 (handler-case
  26     (export :foo)
  27   (package-error (c) (princ c))
  28   (:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args)))
  29
  30 (make-package "FOO")
  31 (assert (shadow #\a :foo))
  32
  33 (defpackage :PACKAGE-DESIGNATOR-1 (:use #.(find-package :cl)))
  34
  35 (defpackage :PACKAGE-DESIGNATOR-2
  36   (:import-from #.(find-package :cl) "+"))
  37
  38 (defpackage "EXAMPLE-INDIRECT"
  39   (:import-from "CL" "+"))
  40
  41 (defpackage "EXAMPLE-PACKAGE"
  42   (:shadow "CAR")
  43   (:shadowing-import-from "CL" "CAAR")
  44   (:use)
  45   (:import-from "CL" "CDR")
  46   (:import-from "EXAMPLE-INDIRECT" "+")
  47   (:export "CAR" "CDR" "EXAMPLE"))
  48
  49 (flet ((check-symbol (name expected-status expected-home-name)
  50          (multiple-value-bind (symbol status)
  51              (find-symbol name "EXAMPLE-PACKAGE")
  52            (let ((home (symbol-package symbol))
  53                  (expected-home (find-package expected-home-name)))
  54              (assert (eql home expected-home))
  55              (assert (eql status expected-status))))))
  56   (check-symbol "CAR" :external "EXAMPLE-PACKAGE")
  57   (check-symbol "CDR" :external "CL")
  58   (check-symbol "EXAMPLE" :external "EXAMPLE-PACKAGE")
  59   (check-symbol "CAAR" :internal "CL")
  60   (check-symbol "+" :internal "CL")
  61   (check-symbol "CDDR" nil "CL"))
  62
  63 (defpackage "TEST-ORIGINAL" (:nicknames "A-NICKNAME"))
  64
  65 (assert (raises-error? (defpackage "A-NICKNAME")))
  66
  67 (assert (eql (find-package "A-NICKNAME")
  68              (find-package "TEST-ORIGINAL")))
  69
  70 ;;;; Utilities
  71 (defun sym (package name)
  72  (let ((package (or (find-package package) package)))
  73    (multiple-value-bind (symbol status)
  74        (find-symbol name package)
  75      (assert status
  76              (package name symbol status)
  77              "No symbol with name ~A in ~S." name package symbol status)
  78    (values symbol status))))
  79
  80 (defmacro with-name-conflict-resolution ((symbol &key restarted)
  81                                          form &body body)
  82   "Resolves potential name conflict condition arising from FORM.
  83
  84 The conflict is resolved in favour of SYMBOL, a form which must
  85 evaluate to a symbol.
  86
  87 If RESTARTED is a symbol, it is bound for the BODY forms and set to T
  88 if a restart was invoked."
  89   (check-type restarted symbol "a binding name")
  90   (let ((%symbol (copy-symbol 'symbol)))
  91     `(let (,@(when restarted `((,restarted)))
  92            (,%symbol ,symbol))
  93        (handler-bind
  94            ((sb-ext:name-conflict
  95              (lambda (condition)
  96                ,@(when restarted `((setf ,restarted t)))
  97                (assert (member ,%symbol (sb-ext:name-conflict-symbols condition)))
  98                (invoke-restart 'sb-ext:resolve-conflict ,%symbol))))
  99          ,form)
 100        ,@body)))
 101
 102 (defmacro with-packages (specs &body forms)
 103   (let ((names (mapcar #'car specs)))
 104     `(unwind-protect
 105           (progn
 106             (delete-packages ',names)
 107             ,@(mapcar (lambda (spec)
 108                         `(defpackage ,@spec))
 109                       specs)
 110             ,@forms)
 111        (delete-packages ',names))))
 112
 113 (defun delete-packages (names)
 114   (dolist (p names)
 115     (ignore-errors (delete-package p))))
 116
 117
 118 ;;;; Tests
 119 ;;; USE-PACKAGE
 120 (with-test (:name use-package.1)
 121   (with-packages (("FOO" (:export "SYM"))
 122                   ("BAR" (:export "SYM"))
 123                   ("BAZ" (:use)))
 124     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
 125         (use-package '("FOO" "BAR") "BAZ")
 126       (is restartedp)
 127       (is (eq (sym "BAR" "SYM")
 128               (sym "BAZ" "SYM"))))))
 129
 130 (with-test (:name use-package.2)
 131   (with-packages (("FOO" (:export "SYM"))
 132                   ("BAZ" (:use) (:intern "SYM")))
 133     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 134         (use-package "FOO" "BAZ")
 135       (is restartedp)
 136       (is (eq (sym "FOO" "SYM")
 137               (sym "BAZ" "SYM"))))))
 138
 139 (with-test (:name use-package.2a)
 140   (with-packages (("FOO" (:export "SYM"))
 141                   ("BAZ" (:use) (:intern "SYM")))
 142     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
 143         (use-package "FOO" "BAZ")
 144       (is restartedp)
 145       (is (equal (list (sym "BAZ" "SYM") :internal)
 146                  (multiple-value-list (sym "BAZ" "SYM")))))))
 147
 148 (with-test (:name use-package-conflict-set :fails-on :sbcl)
 149   (with-packages (("FOO" (:export "SYM"))
 150                   ("QUX" (:export "SYM"))
 151                   ("BAR" (:intern "SYM"))
 152                   ("BAZ" (:use) (:import-from "BAR" "SYM")))
 153     (let ((conflict-set))
 154       (block nil
 155         (handler-bind
 156             ((sb-ext:name-conflict
 157               (lambda (condition)
 158                 (setf conflict-set (copy-list
 159                                     (sb-ext:name-conflict-symbols condition)))
 160                 (return))))
 161           (use-package '("FOO" "QUX") "BAZ")))
 162       (setf conflict-set
 163             (sort conflict-set #'string<
 164                   :key (lambda (symbol)
 165                          (package-name (symbol-package symbol)))))
 166       (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM"))
 167                  conflict-set)))))
 168
 169 ;;; EXPORT
 170 (with-test (:name export.1)
 171   (with-packages (("FOO" (:intern "SYM"))
 172                   ("BAR" (:export "SYM"))
 173                   ("BAZ" (:use "FOO" "BAR")))
 174     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 175         (export (sym "FOO" "SYM") "FOO")
 176       (is restartedp)
 177       (is (eq (sym "FOO" "SYM")
 178               (sym "BAZ" "SYM"))))))
 179
 180 (with-test (:name export.1a)
 181   (with-packages (("FOO" (:intern "SYM"))
 182                   ("BAR" (:export "SYM"))
 183                   ("BAZ" (:use "FOO" "BAR")))
 184     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
 185         (export (sym "FOO" "SYM") "FOO")
 186       (is restartedp)
 187       (is (eq (sym "BAR" "SYM")
 188               (sym "BAZ" "SYM"))))))
 189
 190 (with-test (:name export.ensure-exported)
 191   (with-packages (("FOO" (:intern "SYM"))
 192                   ("BAR" (:export "SYM"))
 193                   ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM")))
 194     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 195         (export (sym "FOO" "SYM") "FOO")
 196       (is restartedp)
 197       (is (equal (list (sym "FOO" "SYM") :external)
 198                  (multiple-value-list (sym "FOO" "SYM"))))
 199       (is (eq (sym "FOO" "SYM")
 200               (sym "BAZ" "SYM"))))))
 201
 202 (with-test (:name export.3.intern)
 203   (with-packages (("FOO" (:intern "SYM"))
 204                   ("BAZ" (:use "FOO") (:intern "SYM")))
 205     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 206         (export (sym "FOO" "SYM") "FOO")
 207       (is restartedp)
 208       (is (eq (sym "FOO" "SYM")
 209               (sym "BAZ" "SYM"))))))
 210
 211 (with-test (:name export.3a.intern)
 212   (with-packages (("FOO" (:intern "SYM"))
 213                   ("BAZ" (:use "FOO") (:intern "SYM")))
 214     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
 215         (export (sym "FOO" "SYM") "FOO")
 216       (is restartedp)
 217       (is (equal (list (sym "BAZ" "SYM") :internal)
 218                  (multiple-value-list (sym "BAZ" "SYM")))))))
 219
 220 ;;; IMPORT
 221 (with-test (:name import-nil.1)
 222   (with-packages (("FOO" (:use) (:intern "NIL"))
 223                   ("BAZ" (:use) (:intern "NIL")))
 224     (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp)
 225         (import (list (sym "FOO" "NIL")) "BAZ")
 226       (is restartedp)
 227       (is (eq (sym "FOO" "NIL")
 228               (sym "BAZ" "NIL"))))))
 229
 230 (with-test (:name import-nil.2)
 231   (with-packages (("BAZ" (:use) (:intern "NIL")))
 232     (with-name-conflict-resolution ('CL:NIL :restarted restartedp)
 233         (import '(CL:NIL) "BAZ")
 234       (is restartedp)
 235       (is (eq 'CL:NIL
 236               (sym "BAZ" "NIL"))))))
 237
 238 (with-test (:name import-single-conflict :fails-on :sbcl)
 239   (with-packages (("FOO" (:export "NIL"))
 240                   ("BAR" (:export "NIL"))
 241                   ("BAZ" (:use)))
 242     (let ((conflict-sets '()))
 243       (handler-bind
 244           ((sb-ext:name-conflict
 245             (lambda (condition)
 246               (push (copy-list (sb-ext:name-conflict-symbols condition))
 247                     conflict-sets)
 248               (invoke-restart 'sb-ext:resolve-conflict 'CL:NIL))))
 249         (import (list 'CL:NIL (sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ"))
 250       (is (eql 1 (length conflict-sets)))
 251       (is (eql 3 (length (first conflict-sets)))))))
 252
 253 ;;; Make sure that resolving a name-conflict in IMPORT doesn't leave
 254 ;;; multiple symbols of the same name in the package (this particular
 255 ;;; scenario found in 1.0.38.9, but clearly a longstanding issue).
 256 (with-test (:name import-conflict-resolution)
 257   (with-packages (("FOO" (:export "NIL"))
 258                   ("BAR" (:use)))
 259     (with-name-conflict-resolution ((sym "FOO" "NIL"))
 260       (import (list 'CL:NIL (sym "FOO" "NIL")) "BAR"))
 261     (do-symbols (sym "BAR")
 262       (assert (eq sym (sym "FOO" "NIL"))))))
 263
 264 ;;; UNINTERN
 265 (with-test (:name unintern.1)
 266   (with-packages (("FOO" (:export "SYM"))
 267                   ("BAR" (:export "SYM"))
 268                   ("BAZ" (:use "FOO" "BAR") (:shadow "SYM")))
 269     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 270         (unintern (sym "BAZ" "SYM") "BAZ")
 271       (is restartedp)
 272       (is (eq (sym "FOO" "SYM")
 273               (sym "BAZ" "SYM"))))))
 274
 275 (with-test (:name unintern.2)
 276   (with-packages (("FOO" (:intern "SYM")))
 277     (unintern :sym "FOO")
 278     (assert (find-symbol "SYM" "FOO"))))
 279
 280 ;;; WITH-PACKAGE-ITERATOR error signalling had problems
 281 (with-test (:name with-package-itarator.error)
 282   (assert (eq :good
 283               (handler-case
 284                   (progn
 285                     (eval '(with-package-iterator (sym :cl-user :foo)
 286                             (sym)))
 287                     :bad)
 288                 ((and simple-condition program-error) (c)
 289                   (assert (equal (list :foo) (simple-condition-format-arguments c)))
 290                   :good)))))
 291
 292 ;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
 293 (with-test (:name :bug-511072 :skipped-on '(not :sb-thread))
 294   (let* ((p (make-package :bug-511072))
 295          (sem1 (sb-thread:make-semaphore))
 296          (sem2 (sb-thread:make-semaphore))
 297          (t2 (sb-thread:make-thread (lambda ()
 298                                       (handler-bind ((error (lambda (c)
 299                                                               (sb-thread:signal-semaphore sem1)
 300                                                               (sb-thread:wait-on-semaphore sem2)
 301                                                               (abort c))))
 302                                         (make-package :bug-511072))))))
 303     (sb-thread:wait-on-semaphore sem1)
 304     (with-timeout 10
 305       (assert (eq 'cons (read-from-string "CL:CONS"))))
 306     (sb-thread:signal-semaphore sem2)))