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

Last change on this file since 9045 was 9045, checked in by gz, 12 years ago

Assorted cleanup:

In infrastructure:

  • add *test-verbose* and :verbose argument to do-test and do-tests. Avoid random output if false, only show failures
  • muffle-wawrnings and/or bind *suppress-compiler-warnings* in some tests that unavoidably generate them (mainly with duplicate typecase/case clauses)
  • Add record-source-file for tests so meta-. can find them
  • If *catch-errors* (or the :catch-errors arg) is :break, enter a breakloop when catch an error
  • Make test fns created by *compile-tests* have names, so can find them in backtraces
  • fix misc compiler warnings
  • Fixed cases of duplicate test numbers
  • Disable note :make-condition-with-compound-name for openmcl.

In tests themselves:

I commented out the following tests with #+bogus-test, because they just seemed wrong to me:

lambda.47
lambda.50
upgraded-array-element-type.8
upgraded-array-element-type.nil.1
pathname-match-p.5
load.17
load.18
macrolet.47
ctypecase.15

In addition, I commented out the following tests with #+bogus-test because I was too lazy to make a note
for "doesn't signal underflow":

exp.error.8 exp.error.9 exp.error.10 exp.error.11 expt.error.8 expt.error.9 expt.error.10 expt.error.11

Finally, I entered bug reports in trac, and then commented out the tests
below with #+known-bug-NNN, where nnn is the ticket number in trac:

ticket#268: encode-universal-time.3 encode-universal-time.3.1
ticket#269: macrolet.36
ticket#270: values.20 values.21
ticket#271: defclass.error.13 defclass.error.22
ticket#272: phase.10 phase.12 asin.5 asin.6 asin.8
ticket#273: phase.18 phase.19 acos.8
ticket#274: exp.error.4 exp.error.5 exp.error.6 exp.error.7
ticket#275: car.error.2 cdr.error.2
ticket#276: map.error.11
ticket#277: subtypep.cons.43
ticket#278: subtypep-function.3
ticket#279: subtypep-complex.8
ticket#280: open.output.19 open.io.19 file-position.8 file-length.4 file-length.5 read-byte.4 stream-element-type.2 stream-element-type.3
ticket#281: open.65
ticket#288: set-syntax-from-char.sharp.1

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                   (when *test-verbose* (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.