10 |
;;; unexport |
;;; unexport |
11 |
|
|
12 |
(deftest unexport-1 |
(deftest unexport-1 |
13 |
(handler-case |
(handler-case |
14 |
(progn |
(progn |
15 |
(ignore-errors (delete-package "X")) |
(ignore-errors (delete-package "X")) |
16 |
(let* ((p (make-package "X" :use nil)) |
(let* ((p (make-package "X" :use nil)) |
17 |
(r (export (intern "X" p) p))) |
(r (export (intern "X" p) p))) |
18 |
(multiple-value-bind (sym1 access1) |
(multiple-value-bind (sym1 access1) |
19 |
(find-symbol "X" p) |
(find-symbol "X" p) |
20 |
(unexport sym1 p) |
(unexport sym1 p) |
21 |
(multiple-value-bind (sym2 access2) |
(multiple-value-bind (sym2 access2) |
22 |
(find-symbol "X" p) |
(find-symbol "X" p) |
23 |
(and (eq r t) |
(and (eqt r t) |
24 |
(eq sym1 sym2) |
(eqt sym1 sym2) |
25 |
(eq access1 :external) |
(eqt access1 :external) |
26 |
(eq access2 :internal) |
(eqt access2 :internal) |
27 |
(equal (symbol-name sym1) "X")))))) |
(equal (symbol-name sym1) "X") |
28 |
(error (c) c)) |
t))))) |
29 |
|
(error (c) c)) |
30 |
t) |
t) |
31 |
|
|
32 |
(deftest unexport-2 |
(deftest unexport-2 |
33 |
(handler-case |
(handler-case |
34 |
(progn |
(progn |
35 |
(ignore-errors (delete-package "X")) |
(ignore-errors (delete-package "X")) |
36 |
(let* ((p (make-package "X" :use nil)) |
(let* ((p (make-package "X" :use nil)) |
37 |
(r (export (intern "X" p) p))) |
(r (export (intern "X" p) p))) |
38 |
(multiple-value-bind (sym1 access1) |
(multiple-value-bind (sym1 access1) |
39 |
(find-symbol "X" p) |
(find-symbol "X" p) |
40 |
(unexport (list sym1) "X") |
(unexport (list sym1) "X") |
41 |
(multiple-value-bind (sym2 access2) |
(multiple-value-bind (sym2 access2) |
42 |
(find-symbol "X" p) |
(find-symbol "X" p) |
43 |
(and (eq sym1 sym2) |
(and (eqt sym1 sym2) |
44 |
(eq r t) |
(eqt r t) |
45 |
(eq access1 :external) |
(eqt access1 :external) |
46 |
(eq access2 :internal) |
(eqt access2 :internal) |
47 |
(equal (symbol-name sym1) "X")))))) |
(equal (symbol-name sym1) "X") |
48 |
(error (c) c)) |
t))))) |
49 |
|
(error (c) c)) |
50 |
t) |
t) |
51 |
|
|
52 |
(deftest unexport-3 |
(deftest unexport-3 |
53 |
(handler-case |
(handler-case |
54 |
(progn |
(progn |
55 |
(ignore-errors (delete-package "X")) |
(ignore-errors (delete-package "X")) |
56 |
(let* ((p (make-package "X" :use nil)) |
(let* ((p (make-package "X" :use nil)) |
57 |
(r1 (export (intern "X" p) p)) |
(r1 (export (intern "X" p) p)) |
58 |
(r2 (export (intern "Y" p) p))) |
(r2 (export (intern "Y" p) p))) |
59 |
(multiple-value-bind (sym1 access1) |
(multiple-value-bind (sym1 access1) |
60 |
(find-symbol "X" p) |
(find-symbol "X" p) |
61 |
(multiple-value-bind (sym1a access1a) |
(multiple-value-bind (sym1a access1a) |
62 |
(find-symbol "Y" p) |
(find-symbol "Y" p) |
63 |
(unexport (list sym1 sym1a) '#:|X|) |
(unexport (list sym1 sym1a) '#:|X|) |
64 |
(multiple-value-bind (sym2 access2) |
(multiple-value-bind (sym2 access2) |
65 |
(find-symbol "X" p) |
(find-symbol "X" p) |
66 |
(multiple-value-bind (sym2a access2a) |
(multiple-value-bind (sym2a access2a) |
67 |
(find-symbol "Y" p) |
(find-symbol "Y" p) |
68 |
(and (eq sym1 sym2) |
(and (eqt sym1 sym2) |
69 |
(eq sym1a sym2a) |
(eqt sym1a sym2a) |
70 |
(eq r1 t) |
(eqt r1 t) |
71 |
(eq r2 t) |
(eqt r2 t) |
72 |
(eq access1 :external) |
(eqt access1 :external) |
73 |
(eq access2 :internal) |
(eqt access2 :internal) |
74 |
(eq access1a :external) |
(eqt access1a :external) |
75 |
(eq access2a :internal) |
(eqt access2a :internal) |
76 |
(equal (symbol-name sym1) "X") |
(equal (symbol-name sym1) "X") |
77 |
(equal (symbol-name sym1a) "Y")))))))) |
(equal (symbol-name sym1a) "Y") |
78 |
(error (c) c)) |
t))))))) |
79 |
|
(error (c) c)) |
80 |
t) |
t) |
81 |
|
|
82 |
(deftest unexport-4 |
(deftest unexport-4 |
83 |
(handler-case |
(handler-case |
84 |
(progn |
(progn |
85 |
(ignore-errors (delete-package "X")) |
(ignore-errors (delete-package "X")) |
86 |
(let* ((p (make-package "X" :use nil)) |
(let* ((p (make-package "X" :use nil)) |
87 |
(r (export (intern "X" p) p))) |
(r (export (intern "X" p) p))) |
88 |
(multiple-value-bind (sym1 access1) |
(multiple-value-bind (sym1 access1) |
89 |
(find-symbol "X" p) |
(find-symbol "X" p) |
90 |
(unexport (list sym1) #\X) |
(unexport (list sym1) #\X) |
91 |
(multiple-value-bind (sym2 access2) |
(multiple-value-bind (sym2 access2) |
92 |
(find-symbol "X" p) |
(find-symbol "X" p) |
93 |
(and (eq sym1 sym2) |
(and (eqt sym1 sym2) |
94 |
(eq r t) |
(eqt r t) |
95 |
(eq access1 :external) |
(eqt access1 :external) |
96 |
(eq access2 :internal) |
(eqt access2 :internal) |
97 |
(equal (symbol-name sym1) "X")))))) |
(equal (symbol-name sym1) "X") |
98 |
(error (c) c)) |
t))))) |
99 |
|
(error (c) c)) |
100 |
t) |
t) |
101 |
|
|
102 |
;; Check that it signals a package error when unexporting |
;; Check that it signals a package error when unexporting |
103 |
;; an inaccessible symbol |
;; an inaccessible symbol |
104 |
|
|
105 |
(deftest unexport-5 |
(deftest unexport-5 |
106 |
(handler-case |
(handler-case |
107 |
(progn |
(progn |
108 |
(when (find-package "X") (delete-package "X")) |
(when (find-package "X") (delete-package "X")) |
109 |
(unexport 'a (make-package "X" :use nil)) |
(unexport 'a (make-package "X" :use nil)) |
110 |
nil) |
nil) |
111 |
(package-error () t) |
(package-error () t) |
112 |
(error (c) c)) |
(error (c) c)) |
113 |
t) |
t) |
114 |
|
|
115 |
;; Check that internal symbols are left alone |
;; Check that internal symbols are left alone |
116 |
|
|
117 |
(deftest unexport-6 |
(deftest unexport-6 |
118 |
(handler-case |
(handler-case |
119 |
(progn |
(progn |
120 |
(when (find-package "X") (delete-package "X")) |
(when (find-package "X") (delete-package "X")) |
121 |
(let ((p (make-package "X" :use nil))) |
(let ((p (make-package "X" :use nil))) |
122 |
(let* ((sym (intern "FOO" p)) |
(let* ((sym (intern "FOO" p)) |
123 |
(r (unexport sym p))) |
(r (unexport sym p))) |
124 |
(multiple-value-bind (sym2 access) |
(multiple-value-bind (sym2 access) |
125 |
(find-symbol "FOO" p) |
(find-symbol "FOO" p) |
126 |
(and (eq r t) |
(and (eqt r t) |
127 |
(eq access :internal) |
(eqt access :internal) |
128 |
(eq sym sym2) |
(eqt sym sym2) |
129 |
(equal (symbol-name sym) "FOO")))))) |
(equal (symbol-name sym) "FOO") |
130 |
(error (c) c)) |
t))))) |
131 |
|
(error (c) c)) |
132 |
t) |
t) |