/[gcl]/gcl/ansi-tests/packages-11.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/packages-11.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Thu Sep 26 16:53:38 2002 UTC revision 1.2 by pfdietz, Thu Oct 17 13:16:56 2002 UTC
# Line 10  Line 10 
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)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26