/[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.5 by pfdietz, Fri Jan 24 04:22:54 2003 UTC revision 1.6 by pfdietz, Sat Feb 15 05:11:11 2003 UTC
# Line 9  Line 9 
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

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

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