source: trunk/source/tests/ansi-tests/delete-package.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: 5.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 25 08:01:58 1998
4;;;; Contains: Tests of DELETE-PACKAGE
5
6(in-package :cl-test)
7(declaim (optimize (safety 3)))
8;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9;;; delete-package
10
11;; check return value of delete-package, and check
12;; that package-name is nil on the deleted package object
13(deftest delete-package.1
14  (progn
15    (safely-delete-package :test1)
16    (let ((p (make-package :test1 :use nil)))
17      (list
18       (notnot (delete-package :test1))
19       (notnot (packagep p))
20       (package-name p))))
21  (t t nil))
22
23(deftest delete-package.2
24  (progn
25    (safely-delete-package :test1)
26    (let ((p (make-package :test1 :use nil)))
27      (list
28       (notnot (delete-package :test1))
29       (notnot (packagep p))
30       (delete-package p))))
31  (t t nil))
32
33;; Check that deletion of different package designators works
34(deftest delete-package.3
35  (progn
36    (safely-delete-package "X")
37    (make-package "X")
38    (handler-case
39     (notnot (delete-package "X"))
40     (error (c) c)))
41  t)
42
43(deftest delete-package.4
44  (progn
45    (safely-delete-package "X")
46    (make-package "X")
47    (handler-case
48     (notnot (delete-package #\X))
49     (error (c) c)))
50  t)
51
52;;; PFD 10/14/02 -- These tests are broken again.  I suspect
53;;;   some sort of interaction with the test harness.
54
55;;; PFD 01.18.03  This test is working, but suspicious.
56
57(deftest delete-package.5
58  (prog (p1 s1 p2 s2 p3)
59        (declare (ignorable p1 p2 p3 s1 s2))
60        (safely-delete-package "P3")
61        (safely-delete-package "P2")
62        (safely-delete-package "P1")
63       
64        (setq p1 (make-package "P1" :use ()))
65        (setq s1 (intern "S1" P1))
66        (export s1 "P1")
67       
68        (setq p2 (make-package "P2" :use '("P1")))
69        (setq s2  (intern "S2" p2))
70        (export s1 p2)
71        (export s2 "P2")
72       
73        (setf p3 (make-package "P3" :use '("P2")))
74       
75        ;; Delete the P2 package, catching the continuable
76        ;; error and deleting the package
77
78        (let ((outer-restarts (compute-restarts)))
79          (handler-bind ((package-error
80                          #'(lambda (c)
81                              ;; (let ((r (find-restart 'continue c))) (and r (invoke-restart r)))
82                              (let ((my-restarts
83                                     (remove 'abort
84                                             (set-difference (compute-restarts c)
85                                                             outer-restarts)
86                                             :key #'restart-name)))
87                                (assert my-restarts)
88                                (when (find 'continue my-restarts :key #'restart-name)
89                                  (continue c))
90                                (return t)
91                                ))))
92                      (delete-package p2)))
93       
94        (unless (and (equal (package-name P1) "P1")
95                     (null  (package-name P2))
96                     (equal (package-name P3) "P3"))
97          (return 'fail1))
98       
99        (unless (eqt (symbol-package S1) P1)
100          (return 'fail2))
101        (unless (equal (prin1-to-string S1) "P1:S1")
102          (return 'fail3))
103       
104        (unless (equal (multiple-value-list (find-symbol "S1" P3))
105                       '(nil nil))
106          (return 'fail4))
107       
108        (unless (equal (multiple-value-list (find-symbol "S2" P3))
109                       '(nil nil))
110          (return 'fail5))
111       
112        (unless (and (null (package-used-by-list P1))
113                     (null (package-used-by-list P3)))
114          (return 'fail6))
115       
116        (unless (and (packagep P1)
117                     (packagep P2)
118                     (packagep P3)) (return 'fail7))
119       
120        (unless (and (null (package-use-list P1))
121                     (null (package-use-list P3)))
122          (return 'fail8))
123       
124        (safely-delete-package P3)
125        (safely-delete-package P1)
126        (return t)
127        )
128  t)
129
130;; deletion of a nonexistent package should cause a continuable
131;; package-error  (same comments for delete-package.5 apply
132;; here as well)
133
134(deftest delete-package.6
135  (block done
136    (let ((outer-restarts (compute-restarts)))
137      (safely-delete-package "TEST-20")
138      (handler-bind ((package-error
139                      #'(lambda (c)
140                          (assert (set-difference (compute-restarts c)
141                                                  outer-restarts))
142                          (return-from done :good))))
143                    (delete-package "TEST-20"))))
144  :good)
145
146;;; Specialized sequences
147
148(defmacro def-delete-package-test (test-name name-form)
149  `(deftest ,test-name
150     (let ((name ,name-form))
151       (safely-delete-package name)
152       (let ((p (make-package name :use nil)))
153         (list
154          (notnot (delete-package :test1))
155          (notnot (packagep p))
156          (package-name p))))
157     (t t nil)))
158
159(def-delete-package-test delete-package.7
160  (make-array '(5) :initial-contents "TEST1"
161              :element-type 'base-char))
162
163(def-delete-package-test delete-package.8
164  (make-array '(10) :initial-contents "TEST1XXXXX"
165              :fill-pointer 5
166              :element-type 'base-char))
167
168(def-delete-package-test delete-package.9
169  (make-array '(10) :initial-contents "TEST1XXXXX"
170              :fill-pointer 5
171              :element-type 'character))
172
173(def-delete-package-test delete-package.10
174  (make-array '(5) :initial-contents "TEST1"
175              :adjustable t
176              :element-type 'base-char))
177
178(def-delete-package-test delete-package.11
179  (make-array '(5) :initial-contents "TEST1"
180              :adjustable t
181              :element-type 'character))
182
183(def-delete-package-test delete-package.12
184  (let* ((etype 'character)
185         (name2 (make-array '(10) :initial-contents "XXXTEST1YY"
186                            :element-type etype)))
187    (make-array '(5) :displaced-to name2
188                :displaced-index-offset 3
189                :element-type etype)))
190
191(def-delete-package-test delete-package.13
192  (let* ((etype 'base-char)
193         (name2 (make-array '(10) :initial-contents "XXXTEST1YY"
194                            :element-type etype)))
195    (make-array '(5) :displaced-to name2
196                :displaced-index-offset 3
197                :element-type etype)))
198
199;;; Error tests
200
201(deftest delete-package.error.1
202  (signals-error (delete-package) program-error)
203  t)
204
205(deftest delete-package.error.2
206  (progn
207    (unless (find-package "TEST-DPE2")
208      (make-package "TEST-DPE2" :use nil))
209    (signals-error (delete-package "TEST-DPE2" nil)
210                   program-error))
211  t)
Note: See TracBrowser for help on using the repository browser.