source: trunk/source/tests/ansi-tests/unintern.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 8.1 KB
Line 
1();-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 25 08:04:56 1998
4;;;; Contains: Tests of UNINTERN
5
6(in-package :cl-test)
7(declaim (optimize (safety 3)))
8
9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10;;; unintern
11
12;; Simple unintern of an internal symbol, package explicitly
13;; given as a package object
14(deftest unintern.1
15  (progn
16    (safely-delete-package "H")
17    (prog1
18        (let ((p (make-package "H" :use nil))
19              (i 0) x y)
20          (intern "FOO" p)
21          (multiple-value-bind*
22           (sym access)
23           (find-symbol "FOO" p)
24           (and
25            (eqt access :internal)
26            (unintern (progn (setf x (incf i)) sym)
27                      (progn (setf y (incf i)) p))
28            (eql i 2) (eql x 1) (eql y 2)
29            (null (symbol-package sym))
30            (not (find-symbol "FOO" p)))))
31      (safely-delete-package "H")))
32  t)
33
34;; Simple unintern, package taken from the *PACKAGES*
35;; special variable (should this have unwind protect?)
36(deftest unintern.2
37  (progn
38    (safely-delete-package "H")
39    (prog1
40        (let ((*PACKAGE* (make-package "H" :use nil)))
41          (intern "FOO")
42          (multiple-value-bind* (sym access)
43              (find-symbol "FOO")
44            (and
45             (eqt access :internal)
46             (unintern sym)
47             (null (symbol-package sym))
48             (not (find-symbol "FOO")))))
49      (safely-delete-package "H")))
50  t)
51
52;; Simple unintern, package given as string
53(deftest unintern.3
54  (progn
55    (safely-delete-package "H")
56    (prog1
57        (let ((p (make-package "H" :use nil)))
58          (intern "FOO" p)
59          (multiple-value-bind* (sym access)
60              (find-symbol "FOO" p)
61            (and
62             (eqt access :internal)
63             (unintern sym "H")
64             (null (symbol-package sym))
65             (not (find-symbol "FOO" p)))))
66      (safely-delete-package "H")))
67  t)
68
69;; Simple unintern, package given as symbol
70(deftest unintern.4
71  (progn
72    (safely-delete-package "H")
73    (prog1
74        (let ((p (make-package "H" :use nil)))
75          (intern "FOO" p)
76          (multiple-value-bind* (sym access)
77              (find-symbol "FOO" p)
78            (and
79             (eqt access :internal)
80             (unintern sym '#:|H|)
81             (null (symbol-package sym))
82             (not (find-symbol "FOO" p)))))
83      (safely-delete-package "H")))
84  t)
85
86;; Simple unintern, package given as character
87(deftest unintern.5
88  (handler-case
89   (progn
90     (safely-delete-package "H")
91     (prog1
92         (let ((p (make-package "H" :use nil)))
93           (intern "FOO" p)
94           (multiple-value-bind* (sym access)
95               (find-symbol "FOO" p)
96             (and
97              (eqt access :internal)
98              (unintern sym #\H)
99              (null (symbol-package sym))
100              (not (find-symbol "FOO" p)))))
101       (safely-delete-package "H")))
102   (error (c) c))
103  t)
104
105
106;; Test more complex examples of unintern
107
108;; Unintern an external symbol that is also inherited
109
110(deftest unintern.6
111  (handler-case
112   (progn
113     (safely-delete-package "H")
114     (safely-delete-package "G")
115     (make-package "G" :use nil)
116     (export (intern "FOO" "G") "G")
117     (make-package "H" :use '("G"))
118     (export (intern "FOO" "H") "H")
119     ;; At this point, G:FOO is also an external
120     ;; symbol of H.
121     (multiple-value-bind* (sym1 access1)
122         (find-symbol "FOO" "H")
123       (and sym1
124            (eqt access1 :external)
125            (equal "FOO" (symbol-name sym1))
126            (eqt (find-package "G")
127                 (symbol-package sym1))
128            (unintern sym1 "H")
129            (multiple-value-bind* (sym2 access2)
130                (find-symbol "FOO" "H")
131              (and (eqt sym1 sym2)
132                   (eqt (symbol-package sym1)
133                        (find-package "G"))
134                   (eqt access2 :inherited))))))
135   (error (c) c))
136  t)
137
138;; unintern a symbol that is shadowing another symbol
139
140(deftest unintern.7
141    (block failed
142      (safely-delete-package "H")
143      (safely-delete-package "G")
144      (let* ((pg (make-package "G" :use nil))
145             (ph (make-package "H" :use (list pg))))
146        (handler-case
147           (shadow "FOO" ph)
148           (error (c) (return-from failed (list :shadow-error c))))
149        (export (intern "FOO" pg) pg)
150        ;; At this point, H::FOO shadows G:FOO
151        (multiple-value-bind* (sym1 access1)
152            (find-symbol "FOO" ph)
153          (and
154           sym1
155           (eqt (symbol-package sym1) ph)
156           (eqt access1 :internal)
157           (equal (list sym1) (package-shadowing-symbols ph))
158           (unintern sym1 ph)
159           (multiple-value-bind* (sym2 access2)
160               (find-symbol "FOO" ph)
161             (and (not (eqt sym1 sym2))
162                  (eqt access2 :inherited)
163                  (null (symbol-package sym1))
164                  (eqt (symbol-package sym2) pg)))))))
165  t)
166
167;; Error situation: when the symbol is uninterned, creates
168;; a name conflict from two used packages
169(deftest unintern.8
170  (block failed
171    (safely-delete-package "H")
172    (safely-delete-package "G1")
173    (safely-delete-package "G2")
174    (let* ((pg1 (make-package "G1" :use nil))
175           (pg2 (make-package "G2" :use nil))
176           (ph (make-package "H" :use (list pg1 pg2))))
177      (handler-case
178       (shadow "FOO" ph)
179       (error (c) (return-from failed (list :shadow-error c))))
180      (let ((gsym1 (intern "FOO" pg1))
181            (gsym2 (intern "FOO" pg2)))
182        (export gsym1 pg1)
183        (export gsym2 pg2)
184        (multiple-value-bind* (sym1 access1)
185            (find-symbol "FOO" ph)
186          (and
187           (equal (list sym1) (package-shadowing-symbols ph))
188           (not (eqt sym1 gsym1))
189           (not (eqt sym1 gsym2))
190           (eqt (symbol-package sym1) ph)
191           (eqt access1 :internal)
192           (equal (symbol-name sym1) "FOO")
193           (handler-case
194            (progn
195              (unintern sym1 ph)
196              nil)
197            (error (c)
198                   (format t "Properly threw an error: ~S~%" c)
199                   t)))))))
200  t)
201
202;; Now, inherit the same symbol through two intermediate
203;; packages.  No error should occur when the shadowing
204;; is removed
205(deftest unintern.9
206  (block failed
207    (safely-delete-package "H")
208    (safely-delete-package "G1")
209    (safely-delete-package "G2")
210    (safely-delete-package "G3")
211    (let* ((pg3 (make-package "G3" :use nil))
212           (pg1 (make-package "G1" :use (list pg3)))
213           (pg2 (make-package "G2" :use (list pg3)))
214           (ph  (make-package "H"  :use (list pg1 pg2))))
215      (handler-case
216       (shadow "FOO" ph)
217       (error (c) (return-from failed (list :shadow-error c))))
218      (let ((gsym (intern "FOO" pg3)))
219        (export gsym pg3)
220        (export gsym pg1)
221        (export gsym pg2)
222        (multiple-value-bind* (sym access)
223            (find-symbol "FOO" ph)
224          (and
225           (equal (list sym) (package-shadowing-symbols ph))
226           (not (eqt sym gsym))
227           (equal (symbol-name sym) "FOO")
228           (equal (symbol-package sym) ph)
229           (eqt access :internal)
230           (handler-case
231            (and (unintern sym ph)
232                 (multiple-value-bind* (sym2 access2)
233                     (find-symbol "FOO" ph)
234                   (and (eqt gsym sym2)
235                        (eqt access2 :inherited))))
236            (error (c) c)))))))
237  t)
238
239;;; Specialized sequence tests
240
241(defmacro def-unintern-test (test-name name-form)
242  `(deftest ,test-name
243     (let ((name ,name-form))
244       (safely-delete-package name)
245       (prog1
246           (let ((p (make-package name :use nil)))
247             (intern "FOO" p)
248             (multiple-value-bind*
249              (sym access)
250              (find-symbol "FOO" p)
251              (and
252               (eqt access :internal)
253               (unintern sym name)
254               (null (symbol-package sym))
255               (not (find-symbol "FOO" p)))))
256         (safely-delete-package name)))
257     t))
258
259(def-unintern-test unintern.10
260  (make-array 5 :initial-contents "TEST1" :element-type 'base-char))
261
262(def-unintern-test unintern.11
263  (make-array 10 :initial-contents "TEST1ABCDE"
264              :fill-pointer 5 :element-type 'base-char))
265
266(def-unintern-test unintern.12
267  (make-array 10 :initial-contents "TEST1ABCDE"
268              :fill-pointer 5 :element-type 'character))
269
270(def-unintern-test unintern.13
271  (make-array 5 :initial-contents "TEST1"
272              :adjustable t :element-type 'base-char))
273
274(def-unintern-test unintern.14
275  (make-array 5 :initial-contents "TEST1"
276              :adjustable t :element-type 'character))
277
278(def-unintern-test unintern.15
279  (let* ((etype 'base-char)
280         (name0 (make-array 10 :element-type etype
281                            :initial-contents "xxxxxTEST1")))
282    (make-array 5 :element-type etype
283                :displaced-to name0
284                :displaced-index-offset 5)))
285
286(def-unintern-test unintern.16
287  (let* ((etype 'character)
288         (name0 (make-array 10 :element-type etype
289                            :initial-contents "xxxxxTEST1")))
290    (make-array 5 :element-type etype
291                :displaced-to name0
292                :displaced-index-offset 5)))
293
294
295(deftest unintern.error.1
296  (signals-error (unintern) program-error)
297  t)
298
299(deftest unintern.error.2
300  (signals-error (unintern '#:x "CL-TEST" nil) program-error)
301  t)
Note: See TracBrowser for help on using the repository browser.