1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / 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"))))))
258
259 ;;; WITH-PACKAGE-ITERATOR error signalling had problems
260 (with-test (:name with-package-itarator.error)
261   (assert (eq :good
262               (handler-case
263                   (progn
264                     (eval '(with-package-iterator (sym :cl-user :foo)
265                             (sym)))
266                     :bad)
267                 ((and simple-condition program-error) (c)
268                   (assert (equal (list :foo) (simple-condition-format-arguments c)))
269                   :good)))))