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