82ef917ef5e1fcf3378fe0201f71398b0631136e
[sbcl.git] / 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)))