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

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

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

File size: 7.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 25 08:01:20 1998
4;;;; Contains: Tests of SHADOW
5
6(in-package :cl-test)
7(declaim (optimize (safety 3)))
8
9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10;;; shadow
11
12(deftest shadow.1
13  (prog1
14      (progn
15        (safely-delete-package "TEST5")
16        (safely-delete-package "TEST4")
17        (handler-case
18         (let* ((p1 (prog1
19                        (make-package "TEST4" :use nil)
20                      (export (intern "A" "TEST4") "TEST4")))
21                (p2 (make-package "TEST5" :use '("TEST4")))
22                (r1 (package-shadowing-symbols "TEST4"))
23                (r2 (package-shadowing-symbols "TEST5")))
24           (multiple-value-bind* (s1 kind1)
25               (find-symbol "A" p1)
26             (multiple-value-bind* (s2 kind2)
27                 (find-symbol "A" p2)
28               (let ((r3 (shadow "A" p2)))
29                 (multiple-value-bind* (s3 kind3)
30                     (find-symbol "A" p2)
31                   (list
32                    (package-name p1)
33                    (package-name p2)
34                    r1 r2
35                    (symbol-name s1)
36                    (package-name (symbol-package s1))
37                    kind1
38                    (symbol-name s2)
39                    (package-name (symbol-package s2))
40                    kind2
41                    r3
42                    (symbol-name s3)
43                    (package-name (symbol-package s3))
44                    kind3))))))
45         (error (c) c)))
46    (safely-delete-package "TEST5")
47    (safely-delete-package "TEST4"))
48  ("TEST4" "TEST5" nil nil "A" "TEST4" :external
49   "A" "TEST4" :inherited
50   t
51   "A" "TEST5" :internal))
52
53(deftest shadow.2
54  (progn
55    (safely-delete-package "H")
56    (safely-delete-package "G")
57    (handler-case
58     (let* ((p1 (prog1
59                    (make-package "G" :use nil)
60                  (export (intern "A" "G") "G")))
61            (p2 (make-package "H" :use '("G")))
62            (r1 (package-shadowing-symbols "G"))
63            (r2 (package-shadowing-symbols "H")))
64       (multiple-value-bind* (s1 kind1)
65           (find-symbol "A" p1)
66         (multiple-value-bind* (s2 kind2)
67             (find-symbol "A" p2)
68           (let ((r3 (shadow "A" "H")))
69             (multiple-value-bind* (s3 kind3)
70                 (find-symbol "A" p2)
71               (prog1
72                   (list (package-name p1) (package-name p2)
73                         r1 r2 (symbol-name s1) (package-name (symbol-package s1))
74                         kind1 (symbol-name s2) (package-name (symbol-package s2))
75                         kind2 r3 (symbol-name s3) (package-name (symbol-package s3))
76                         kind3)
77                 (safely-delete-package p2)
78                 (safely-delete-package p1)
79                 ))))))
80     (error (c)
81            (safely-delete-package "H")
82            (safely-delete-package "G")
83            c)))
84  ("G" "H" nil nil "A" "G" :external
85   "A" "G" :inherited
86   t
87   "A" "H" :internal))
88
89;; shadow in which the package is given
90;; by a character
91(deftest shadow.3
92  (progn
93    (safely-delete-package "H")
94    (safely-delete-package "G")
95    (handler-case
96     (let* ((p1 (prog1
97                    (make-package "G" :use nil)
98                  (export (intern "A" "G") "G")))
99            (p2 (make-package "H" :use '("G")))
100            (r1 (package-shadowing-symbols "G"))
101            (r2 (package-shadowing-symbols "H")))
102       (multiple-value-bind* (s1 kind1)
103           (find-symbol "A" p1)
104         (multiple-value-bind* (s2 kind2)
105             (find-symbol "A" p2)
106           (let ((r3 (shadow "A" #\H)))
107             (multiple-value-bind* (s3 kind3)
108                 (find-symbol "A" p2)
109               (prog1
110                   (list (package-name p1) (package-name p2)
111                         r1 r2 (symbol-name s1) (package-name (symbol-package s1))
112                         kind1 (symbol-name s2) (package-name (symbol-package s2))
113                         kind2 r3 (symbol-name s3) (package-name (symbol-package s3))
114                         kind3)
115                 (safely-delete-package p2)
116                 (safely-delete-package p1)
117                 ))))))
118     (error (c)
119            (safely-delete-package "H")
120            (safely-delete-package "G")
121            c)))
122  ("G" "H" nil nil "A" "G" :external
123   "A" "G" :inherited
124   t
125   "A" "H" :internal))
126
127
128;; shadow on an existing internal symbol returns the existing symbol
129(deftest shadow.4
130  (prog1
131      (handler-case
132       (progn
133         (safely-delete-package :G)
134         (make-package :G :use nil)
135         (let ((s1 (intern "X" :G)))
136           (shadow "X" :G)
137           (multiple-value-bind* (s2 kind)
138               (find-symbol "X" :G)
139             (list (eqt s1 s2)
140                   (symbol-name s2)
141                   (package-name (symbol-package s2))
142                   kind))))
143       (error (c) c))
144    (safely-delete-package "G"))
145  (t "X" "G" :internal))
146
147
148;; shadow of an existing shadowed symbol returns the symbol
149(deftest shadow.5
150  (prog1
151      (handler-case
152       (progn
153         (safely-delete-package :H)
154         (safely-delete-package :G)
155         (make-package :G :use nil)
156         (export (intern "X" :G) :G)
157         (make-package :H :use '("G"))
158         (shadow "X" :H)
159         (multiple-value-bind* (s1 kind1)
160             (find-symbol "X" :H)
161           (shadow "X" :H)
162           (multiple-value-bind* (s2 kind2)
163               (find-symbol "X" :H)
164             (list (eqt s1 s2) kind1 kind2))))
165       (error (c) c))
166    (safely-delete-package :H)
167    (safely-delete-package :G))
168  (t :internal :internal))
169
170;; Shadow several names simultaneously
171
172(deftest shadow.6
173  (prog1
174      (handler-case
175       (progn
176         (safely-delete-package :G)
177         (make-package :G :use nil)
178         (shadow '("X" "Y" |Z|) :G)
179         (let ((results
180                (append (multiple-value-list
181                         (find-symbol "X" :G))
182                        (multiple-value-list
183                         (find-symbol "Y" :G))
184                        (multiple-value-list
185                         (find-symbol "Z" :G))
186                        nil)))
187           (list
188            (symbol-name (first results))
189            (second results)
190            (symbol-name (third results))
191            (fourth results)
192            (symbol-name (fifth results))
193            (sixth results)
194            (length (package-shadowing-symbols :G)))))
195       (error (c) c))
196    (safely-delete-package :G))
197  ("X" :internal "Y" :internal "Z" :internal 3))
198
199;; Same, but shadow character string designators
200(deftest shadow.7
201  (prog1
202      (handler-case
203       (let ((i 0) x y)
204         (safely-delete-package :G)
205         (make-package :G :use nil)
206         (shadow (progn (setf x (incf i)) '(#\X #\Y))
207                 (progn (setf y (incf i)) :G))
208         (let ((results
209                (append (multiple-value-list
210                         (find-symbol "X" :G))
211                        (multiple-value-list
212                         (find-symbol "Y" :G))
213                        nil)))
214           (list
215            i x y
216            (symbol-name (first results))
217            (second results)
218            (symbol-name (third results))
219            (fourth results)
220            (length (package-shadowing-symbols :G)))))
221       (error (c) c))
222    (safely-delete-package :G))
223  (2 1 2 "X" :internal "Y" :internal 2))
224
225;;; Specialized string tests
226
227(deftest shadow.8
228  (prog1
229      (handler-case
230       (progn
231         (safely-delete-package :G)
232         (make-package :G :use nil)
233         (let* ((name (make-array '(1) :initial-contents "X"
234                                  :element-type 'base-char))
235                (s1 (intern name :G)))
236           (shadow name :G)
237           (multiple-value-bind* (s2 kind)
238               (find-symbol "X" :G)
239             (list (eqt s1 s2)
240                   (symbol-name s2)
241                   (package-name (symbol-package s2))
242                   kind))))
243       (error (c) c))
244    (safely-delete-package "G"))
245  (t "X" "G" :internal))
246
247(deftest shadow.9
248  (prog1
249      (handler-case
250       (progn
251         (safely-delete-package :G)
252         (make-package :G :use nil)
253         (let* ((name (make-array '(3) :initial-contents "XYZ"
254                                  :fill-pointer 1
255                                  :element-type 'character))
256                (s1 (intern name :G)))
257           (shadow name :G)
258           (multiple-value-bind* (s2 kind)
259               (find-symbol "X" :G)
260             (list (eqt s1 s2)
261                   (symbol-name s2)
262                   (package-name (symbol-package s2))
263                   kind))))
264       (error (c) c))
265    (safely-delete-package "G"))
266  (t "X" "G" :internal))
267
268(deftest shadow.10
269  (prog1
270      (handler-case
271       (progn
272         (safely-delete-package :G)
273         (make-package :G :use nil)
274         (let* ((name (make-array '(1) :initial-contents "X"
275                                  :adjustable t
276                                  :element-type 'base-char))
277                (s1 (intern name :G)))
278           (shadow name :G)
279           (multiple-value-bind* (s2 kind)
280               (find-symbol "X" :G)
281             (list (eqt s1 s2)
282                   (symbol-name s2)
283                   (package-name (symbol-package s2))
284                   kind))))
285       (error (c) c))
286    (safely-delete-package "G"))
287  (t "X" "G" :internal))
288
289
290
291
292(deftest shadow.error.1
293  (signals-error (shadow) program-error)
294  t)
295
296(deftest shadow.error.2
297  (signals-error (shadow "X" "CL-USER" nil) program-error)
298  t)
Note: See TracBrowser for help on using the repository browser.