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 (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 (handler-case
  21     (export :foo)
  22   (package-error (c) (princ c))
  23   (:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args)))
  24
  25 (make-package "FOO")
  26 (assert (shadow #\a :foo))
  27
  28 (defpackage :PACKAGE-DESIGNATOR-1 (:use #.(find-package :cl)))
  29
  30 (defpackage :PACKAGE-DESIGNATOR-2
  31   (:import-from #.(find-package :cl) "+"))
  32
  33 (defpackage "EXAMPLE-INDIRECT"
  34   (:import-from "CL" "+"))
  35
  36 (defpackage "EXAMPLE-PACKAGE"
  37   (:shadow "CAR")
  38   (:shadowing-import-from "CL" "CAAR")
  39   (:use)
  40   (:import-from "CL" "CDR")
  41   (:import-from "EXAMPLE-INDIRECT" "+")
  42   (:export "CAR" "CDR" "EXAMPLE"))
  43
  44 (flet ((check-symbol (name expected-status expected-home-name)
  45          (multiple-value-bind (symbol status)
  46              (find-symbol name "EXAMPLE-PACKAGE")
  47            (let ((home (symbol-package symbol))
  48                  (expected-home (find-package expected-home-name)))
  49              (assert (eql home expected-home))
  50              (assert (eql status expected-status))))))
  51   (check-symbol "CAR" :external "EXAMPLE-PACKAGE")
  52   (check-symbol "CDR" :external "CL")
  53   (check-symbol "EXAMPLE" :external "EXAMPLE-PACKAGE")
  54   (check-symbol "CAAR" :internal "CL")
  55   (check-symbol "+" :internal "CL")
  56   (check-symbol "CDDR" nil "CL"))
  57
  58 (defpackage "TEST-ORIGINAL" (:nicknames "A-NICKNAME"))
  59
  60 (assert (raises-error? (defpackage "A-NICKNAME")))
  61
  62 (assert (eql (find-package "A-NICKNAME")
  63              (find-package "TEST-ORIGINAL")))
  64
  65 ;;;; Utilities
  66 (defun sym (package name)
  67  (let ((package (or (find-package package) package)))
  68    (multiple-value-bind (symbol status)
  69        (find-symbol name package)
  70      (assert status
  71              (package name symbol status)
  72              "No symbol with name ~A in ~S." name package symbol status)
  73    (values symbol status))))
  74
  75 (defmacro with-name-conflict-resolution ((symbol &key restarted)
  76                                          form &body body)
  77   "Resolves potential name conflict condition arising from FORM.
  78
  79 The conflict is resolved in favour of SYMBOL, a form which must
  80 evaluate to a symbol.
  81
  82 If RESTARTED is a symbol, it is bound for the BODY forms and set to T
  83 if a restart was invoked."
  84   (check-type restarted symbol "a binding name")
  85   (let ((%symbol (copy-symbol 'symbol)))
  86     `(let (,@(when restarted `((,restarted)))
  87            (,%symbol ,symbol))
  88        (handler-bind
  89            ((sb-ext:name-conflict
  90              (lambda (condition)
  91                ,@(when restarted `((setf ,restarted t)))
  92                (assert (member ,%symbol (sb-ext:name-conflict-symbols condition)))
  93                (invoke-restart 'sb-ext:resolve-conflict ,%symbol))))
  94          ,form)
  95        ,@body)))
  96
  97 (defmacro with-packages (specs &body forms)
  98   (let ((names (mapcar #'car specs)))
  99     `(unwind-protect
 100           (progn
 101             (delete-packages ',names)
 102             ,@(mapcar (lambda (spec)
 103                         `(defpackage ,@spec))
 104                       specs)
 105             ,@forms)
 106        (delete-packages ',names))))
 107
 108 (defun delete-packages (names)
 109   (dolist (p names)
 110     (ignore-errors (delete-package p))))
 111
 112
 113 ;;;; Tests
 114 ;;; USE-PACKAGE
 115 (with-test (:name use-package.1)
 116   (with-packages (("FOO" (:export "SYM"))
 117                   ("BAR" (:export "SYM"))
 118                   ("BAZ" (:use)))
 119     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
 120         (use-package '("FOO" "BAR") "BAZ")
 121       (is restartedp)
 122       (is (eq (sym "BAR" "SYM")
 123               (sym "BAZ" "SYM"))))))
 124
 125 (with-test (:name use-package.2)
 126   (with-packages (("FOO" (:export "SYM"))
 127                   ("BAZ" (:use) (:intern "SYM")))
 128     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 129         (use-package "FOO" "BAZ")
 130       (is restartedp)
 131       (is (eq (sym "FOO" "SYM")
 132               (sym "BAZ" "SYM"))))))
 133
 134 (with-test (:name use-package.2a)
 135   (with-packages (("FOO" (:export "SYM"))
 136                   ("BAZ" (:use) (:intern "SYM")))
 137     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
 138         (use-package "FOO" "BAZ")
 139       (is restartedp)
 140       (is (equal (list (sym "BAZ" "SYM") :internal)
 141                  (multiple-value-list (sym "BAZ" "SYM")))))))
 142
 143 (with-test (:name use-package-conflict-set :fails-on :sbcl)
 144   (with-packages (("FOO" (:export "SYM"))
 145                   ("QUX" (:export "SYM"))
 146                   ("BAR" (:intern "SYM"))
 147                   ("BAZ" (:use) (:import-from "BAR" "SYM")))
 148     (let ((conflict-set))
 149       (block nil
 150         (handler-bind
 151             ((sb-ext:name-conflict
 152               (lambda (condition)
 153                 (setf conflict-set (copy-list
 154                                     (sb-ext:name-conflict-symbols condition)))
 155                 (return))))
 156           (use-package '("FOO" "QUX") "BAZ")))
 157       (setf conflict-set
 158             (sort conflict-set #'string<
 159                   :key (lambda (symbol)
 160                          (package-name (symbol-package symbol)))))
 161       (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM"))
 162                  conflict-set)))))
 163
 164 ;;; EXPORT
 165 (with-test (:name export.1)
 166   (with-packages (("FOO" (:intern "SYM"))
 167                   ("BAR" (:export "SYM"))
 168                   ("BAZ" (:use "FOO" "BAR")))
 169     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 170         (export (sym "FOO" "SYM") "FOO")
 171       (is restartedp)
 172       (is (eq (sym "FOO" "SYM")
 173               (sym "BAZ" "SYM"))))))
 174
 175 (with-test (:name export.1a)
 176   (with-packages (("FOO" (:intern "SYM"))
 177                   ("BAR" (:export "SYM"))
 178                   ("BAZ" (:use "FOO" "BAR")))
 179     (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp)
 180         (export (sym "FOO" "SYM") "FOO")
 181       (is restartedp)
 182       (is (eq (sym "BAR" "SYM")
 183               (sym "BAZ" "SYM"))))))
 184
 185 (with-test (:name export.ensure-exported)
 186   (with-packages (("FOO" (:intern "SYM"))
 187                   ("BAR" (:export "SYM"))
 188                   ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM")))
 189     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 190         (export (sym "FOO" "SYM") "FOO")
 191       (is restartedp)
 192       (is (equal (list (sym "FOO" "SYM") :external)
 193                  (multiple-value-list (sym "FOO" "SYM"))))
 194       (is (eq (sym "FOO" "SYM")
 195               (sym "BAZ" "SYM"))))))
 196
 197 (with-test (:name export.3.intern)
 198   (with-packages (("FOO" (:intern "SYM"))
 199                   ("BAZ" (:use "FOO") (:intern "SYM")))
 200     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 201         (export (sym "FOO" "SYM") "FOO")
 202       (is restartedp)
 203       (is (eq (sym "FOO" "SYM")
 204               (sym "BAZ" "SYM"))))))
 205
 206 (with-test (:name export.3a.intern)
 207   (with-packages (("FOO" (:intern "SYM"))
 208                   ("BAZ" (:use "FOO") (:intern "SYM")))
 209     (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp)
 210         (export (sym "FOO" "SYM") "FOO")
 211       (is restartedp)
 212       (is (equal (list (sym "BAZ" "SYM") :internal)
 213                  (multiple-value-list (sym "BAZ" "SYM")))))))
 214
 215 ;;; IMPORT
 216 (with-test (:name import-nil.1)
 217   (with-packages (("FOO" (:use) (:intern "NIL"))
 218                   ("BAZ" (:use) (:intern "NIL")))
 219     (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp)
 220         (import (list (sym "FOO" "NIL")) "BAZ")
 221       (is restartedp)
 222       (is (eq (sym "FOO" "NIL")
 223               (sym "BAZ" "NIL"))))))
 224
 225 (with-test (:name import-nil.2)
 226   (with-packages (("BAZ" (:use) (:intern "NIL")))
 227     (with-name-conflict-resolution ('CL:NIL :restarted restartedp)
 228         (import '(CL:NIL) "BAZ")
 229       (is restartedp)
 230       (is (eq 'CL:NIL
 231               (sym "BAZ" "NIL"))))))
 232
 233 (with-test (:name import-single-conflict :fails-on :sbcl)
 234   (with-packages (("FOO" (:export "NIL"))
 235                   ("BAR" (:export "NIL"))
 236                   ("BAZ" (:use)))
 237     (let ((conflict-sets '()))
 238       (handler-bind
 239           ((sb-ext:name-conflict
 240             (lambda (condition)
 241               (push (copy-list (sb-ext:name-conflict-symbols condition))
 242                     conflict-sets)
 243               (invoke-restart 'sb-ext:resolve-conflict 'CL:NIL))))
 244         (import (list 'CL:NIL (sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ"))
 245       (is (eql 1 (length conflict-sets)))
 246       (is (eql 3 (length (first conflict-sets)))))))
 247
 248 ;;; UNINTERN
 249 (with-test (:name unintern.1)
 250   (with-packages (("FOO" (:export "SYM"))
 251                   ("BAR" (:export "SYM"))
 252                   ("BAZ" (:use "FOO" "BAR") (:shadow "SYM")))
 253     (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp)
 254         (unintern (sym "BAZ" "SYM") "BAZ")
 255       (is restartedp)
 256       (is (eq (sym "FOO" "SYM")
 257               (sym "BAZ" "SYM"))))))