source: trunk/source/tests/ansi-tests/unexport.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: 4.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 25 08:04:19 1998
4;;;; Contains: Tests of UNEXPORT
5
6(in-package :cl-test)
7(declaim (optimize (safety 3)))
8
9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10;;; unexport
11
12(deftest unexport.1
13  (progn
14    (safely-delete-package "X")
15    (let* ((p (make-package "X" :use nil))
16           (r (export (intern "X" p) p))
17           (i 0) x y)
18      (multiple-value-bind*
19       (sym1 access1)
20       (find-symbol "X" p)
21       (unexport (progn (setf x (incf i)) sym1)
22                 (progn (setf y (incf i)) p))
23       (multiple-value-bind*
24        (sym2 access2)
25        (find-symbol "X" p)
26        (and (eqt r t)
27             (eql i 2) (eql x 1) (eql y 2)
28             (eqt sym1 sym2)
29             (eqt access1 :external)
30             (eqt access2 :internal)
31             (equal (symbol-name sym1) "X")
32             t)))))
33  t)
34       
35(deftest unexport.2
36  (progn
37    (safely-delete-package "X")
38    (let* ((p (make-package "X" :use nil))
39           (r (export (intern "X" p) p)))
40      (multiple-value-bind*
41       (sym1 access1)
42       (find-symbol "X" p)
43       (unexport (list sym1) "X")
44       (multiple-value-bind*
45        (sym2 access2)
46        (find-symbol "X" p)
47        (and (eqt sym1 sym2)
48             (eqt r t)
49             (eqt access1 :external)
50             (eqt access2 :internal)
51             (equal (symbol-name sym1) "X")
52             t)))))
53  t)
54
55(deftest unexport.3
56  (progn
57    (safely-delete-package "X")
58    (let* ((p (make-package "X" :use nil))
59           (r1 (export (intern "X" p) p))
60           (r2 (export (intern "Y" p) p)))
61      (multiple-value-bind*
62       (sym1 access1)
63       (find-symbol "X" p)
64       (multiple-value-bind*
65        (sym1a access1a)
66        (find-symbol "Y" p)
67        (unexport (list sym1 sym1a) '#:|X|)
68        (multiple-value-bind*
69         (sym2 access2)
70         (find-symbol "X" p)
71         (multiple-value-bind*
72          (sym2a access2a)
73          (find-symbol "Y" p)
74          (and (eqt sym1 sym2)
75               (eqt sym1a sym2a)
76               (eqt r1 t)
77               (eqt r2 t)
78               (eqt access1 :external)
79               (eqt access2 :internal)
80               (eqt access1a :external)
81               (eqt access2a :internal)
82               (equal (symbol-name sym1) "X")
83               (equal (symbol-name sym1a) "Y")
84               t)))))))
85  t)
86
87(deftest unexport.4
88  (progn
89    (safely-delete-package "X")
90    (let* ((p (make-package "X" :use nil))
91           (r (export (intern "X" p) p)))
92      (multiple-value-bind*
93       (sym1 access1)
94       (find-symbol "X" p)
95       (unexport (list sym1) #\X)
96       (multiple-value-bind*
97        (sym2 access2)
98        (find-symbol "X" p)
99        (and (eqt sym1 sym2)
100             (eqt r t)
101             (eqt access1 :external)
102             (eqt access2 :internal)
103             (equal (symbol-name sym1) "X")
104             t)))))
105  t)
106
107;; Check that it signals a package error when unexporting
108;;  an inaccessible symbol
109
110(deftest unexport.5
111  (signals-error
112   (progn
113     (when (find-package "X") (delete-package "X"))
114     (unexport 'a (make-package "X" :use nil))
115     nil)
116   package-error)
117  t)
118
119;; Check that internal symbols are left alone
120
121(deftest unexport.6
122  (progn
123    (when (find-package "X") (delete-package "X"))
124    (let ((p (make-package "X" :use nil)))
125      (let* ((sym (intern "FOO" p))
126             (r (unexport sym p)))
127        (multiple-value-bind*
128         (sym2 access)
129         (find-symbol "FOO" p)
130         (and (eqt r t)
131              (eqt access :internal)
132              (eqt sym sym2)
133              (equal (symbol-name sym) "FOO")
134              t)))))
135  t)
136
137;;; Specialized sequence tests
138
139(defmacro def-unexport-test (test-name name-form)
140  `(deftest ,test-name
141     (let ((name ,name-form))
142       (safely-delete-package name)
143       (let* ((p (make-package name :use nil))
144              (r (export (intern "X" p) p)))
145         (multiple-value-bind*
146          (sym1 access1)
147          (find-symbol "X" p)
148          (unexport (list sym1) name)
149          (multiple-value-bind*
150           (sym2 access2)
151           (find-symbol "X" p)
152           (and (eqt sym1 sym2)
153                (eqt r t)
154                (eqt access1 :external)
155                (eqt access2 :internal)
156                (equal (symbol-name sym1) "X")
157                t)))))
158     t))
159
160(def-unexport-test unexport.7
161  (make-array 5 :initial-contents "TEST1" :element-type 'base-char))
162
163(def-unexport-test unexport.8
164  (make-array 10 :initial-contents "TEST1ABCDE"
165              :fill-pointer 5 :element-type 'base-char))
166
167(def-unexport-test unexport.9
168  (make-array 10 :initial-contents "TEST1ABCDE"
169              :fill-pointer 5 :element-type 'character))
170
171(def-unexport-test unexport.10
172  (make-array 5 :initial-contents "TEST1"
173              :adjustable t :element-type 'base-char))
174
175(def-unexport-test unexport.11
176  (make-array 5 :initial-contents "TEST1"
177              :adjustable t :element-type 'character))
178
179(def-unexport-test unexport.12
180  (let* ((etype 'base-char)
181         (name0 (make-array 10 :element-type etype
182                            :initial-contents "xxxxxTEST1")))
183    (make-array 5 :element-type etype
184                :displaced-to name0
185                :displaced-index-offset 5)))
186
187(def-unexport-test unexport.13
188  (let* ((etype 'character)
189         (name0 (make-array 10 :element-type etype
190                            :initial-contents "xxxxxTEST1")))
191    (make-array 5 :element-type etype
192                :displaced-to name0
193                :displaced-index-offset 5)))
194
195;;; Error tests
196
197(deftest unexport.error.1
198  (signals-error (unexport) program-error)
199  t)
200
201(deftest unexport.error.2
202  (signals-error (unexport 'xyz "CL-TEST" nil) program-error)
203  t)
Note: See TracBrowser for help on using the repository browser.