source: trunk/source/tests/ansi-tests/use-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: 10.4 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 25 08:08:41 1998
4;;;; Contains: Tests of USE-PACKAGE
5
6(in-package :cl-test)
7
8(compile-and-load "package-aux.lsp")
9
10(declaim (optimize (safety 3)))
11
12;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13;;; use-package
14
15(deftest use-package.1
16  (progn
17    (safely-delete-package "H")
18    (safely-delete-package "G")
19    (let* ((pg (make-package "G" :use nil))
20           (ph (make-package "H" :use nil))
21           (sym1 (intern "FOO" pg))
22           (i 0) x y)
23      (and
24       (eqt (export sym1 pg) t)
25       (null (package-used-by-list pg))
26       (null (package-used-by-list ph))
27       (null (package-use-list pg))
28       (null (package-use-list ph))
29       (eqt (use-package (progn (setf x (incf i)) pg)
30                         (progn (setf y (incf i)) ph))
31            t)  ;; "H" will use "G"
32       (eql i 2) (eql x 1) (eql y 2)
33       (multiple-value-bind (sym2 access)
34           (find-symbol "FOO" ph)
35         (and
36          (eqt access :inherited)
37          (eqt sym1 sym2)))
38       (equal (package-use-list ph) (list pg))
39       (equal (package-used-by-list pg) (list ph))
40       (null (package-use-list pg))
41       (null (package-used-by-list ph))
42       (eqt (unuse-package pg ph) t)
43       (null (find-symbol "FOO" ph)))))
44  t)
45
46(deftest use-package.2
47  (progn
48    (safely-delete-package "H")
49    (safely-delete-package "G")
50    (let* ((pg (make-package "G" :use nil))
51           (ph (make-package "H" :use nil))
52           (sym1 (intern "FOO" pg)))
53      (and
54       (eqt (export sym1 pg) t)
55       (null (package-used-by-list pg))
56       (null (package-used-by-list ph))
57       (null (package-use-list pg))
58       (null (package-use-list ph))
59       (eqt (use-package "G" "H") t)  ;; "H" will use "G"
60       (multiple-value-bind (sym2 access)
61           (find-symbol "FOO" ph)
62         (and
63          (eqt access :inherited)
64          (eqt sym1 sym2)))
65       (equal (package-use-list ph) (list pg))
66       (equal (package-used-by-list pg) (list ph))
67       (null (package-use-list pg))
68       (null (package-used-by-list ph))
69       (eqt (unuse-package pg ph) t)
70       (null (find-symbol "FOO" ph)))))
71  t)
72
73(deftest use-package.3
74  (progn
75    (safely-delete-package "H")
76    (safely-delete-package "G")
77    (let* ((pg (make-package "G" :use nil))
78           (ph (make-package "H" :use nil))
79           (sym1 (intern "FOO" pg)))
80      (and
81       (eqt (export sym1 pg) t)
82       (null (package-used-by-list pg))
83       (null (package-used-by-list ph))
84       (null (package-use-list pg))
85       (null (package-use-list ph))
86       (eqt (use-package '#:|G| '#:|H|) t)  ;; "H" will use "G"
87       (multiple-value-bind (sym2 access)
88           (find-symbol "FOO" ph)
89         (and
90          (eqt access :inherited)
91          (eqt sym1 sym2)))
92       (equal (package-use-list ph) (list pg))
93       (equal (package-used-by-list pg) (list ph))
94       (null (package-use-list pg))
95       (null (package-used-by-list ph))
96       (eqt (unuse-package pg ph) t)
97       (null (find-symbol "FOO" ph)))))
98  t)
99
100(deftest use-package.4
101  (progn
102    (safely-delete-package "H")
103    (safely-delete-package "G")
104    (let* ((pg (make-package "G" :use nil))
105           (ph (make-package "H" :use nil))
106           (sym1 (intern "FOO" pg)))
107      (and
108       (eqt (export sym1 pg) t)
109       (null (package-used-by-list pg))
110       (null (package-used-by-list ph))
111       (null (package-use-list pg))
112       (null (package-use-list ph))
113       (eqt (ignore-errors (use-package #\G #\H))
114            t)  ;; "H" will use "G"
115       (multiple-value-bind (sym2 access)
116           (find-symbol "FOO" ph)
117         (and
118          (eqt access :inherited)
119          (eqt sym1 sym2)))
120       (equal (package-use-list ph) (list pg))
121       (equal (package-used-by-list pg) (list ph))
122       (null (package-use-list pg))
123       (null (package-used-by-list ph))
124       (eqt (unuse-package pg ph) t)
125       (null (find-symbol "FOO" ph)))))
126  t)
127
128;; use lists of packages
129
130(deftest use-package.5
131  (let ((pkgs '("H" "G1" "G2" "G3"))
132        (vars '("FOO1" "FOO2" "FOO3")))
133    (dolist (p pkgs)
134      (safely-delete-package p)
135      (make-package p :use nil))
136    (and
137     (every (complement #'package-use-list) pkgs)
138     (every (complement #'package-used-by-list) pkgs)
139     (every #'(lambda (v p)
140                (export (intern v p) p))
141            vars (cdr pkgs))
142     (progn
143       (dolist (p (cdr pkgs)) (intern "MINE" p))
144       (eqt (use-package (cdr pkgs) (car pkgs)) t))
145     (every #'(lambda (v p)
146                (eqt (find-symbol v p)
147                     (find-symbol v (car pkgs))))
148            vars (cdr pkgs))
149     (null (find-symbol "MINE" (car pkgs)))
150     (every #'(lambda (p)
151                (equal (package-used-by-list p)
152                       (list (find-package (car pkgs)))))
153            (cdr pkgs))
154     (equal (sort-package-list (package-use-list (car pkgs)))
155            (mapcar #'find-package (cdr pkgs)))
156     (every (complement #'package-use-list) (cdr pkgs))
157     (null (package-used-by-list (car pkgs)))))
158  t)
159
160;; Circular package use
161
162(deftest use-package.6
163  (progn
164    (safely-delete-package "H")
165    (safely-delete-package "G")
166    (let ((pg (make-package "G"))
167          (ph (make-package "H"))
168          sym1 sym2 sym3 sym4
169          a1 a2 a3 a4)
170      (prog1
171          (and
172           (export (intern "X" pg) pg)
173           (export (intern "Y" ph) ph)
174           (use-package pg ph)
175           (use-package ph pg)
176           (progn
177             (multiple-value-setq
178                 (sym1 a1) (find-symbol "X" pg))
179             (multiple-value-setq
180                 (sym2 a2) (find-symbol "Y" ph))
181             (multiple-value-setq
182                 (sym3 a3) (find-symbol "Y" pg))
183             (multiple-value-setq
184                 (sym4 a4) (find-symbol "X" ph))
185             (and
186              (eqt a1 :external)
187              (eqt a2 :external)
188              (eqt a3 :inherited)
189              (eqt a4 :inherited)
190              (eqt sym1 sym4)
191              (eqt sym2 sym3)
192              (eqt (symbol-package sym1) pg)
193              (eqt (symbol-package sym2) ph)
194              (unuse-package pg ph)
195              (unuse-package ph pg))))
196        (safely-delete-package pg)
197        (safely-delete-package ph))))
198  t)
199
200;; Check that *PACKAGE* is used as a default
201
202(deftest use-package.7
203  (let ((user-name "H")
204        (used-name "G"))
205    (safely-delete-package user-name)
206    (safely-delete-package used-name)
207    (let* ((pused (make-package used-name :use nil))
208           (puser (make-package user-name :use nil))
209           (sym1 (intern "FOO" pused)))
210      (and
211       (eqt (export sym1 pused) t)
212       (null (package-used-by-list pused))
213       (null (package-used-by-list puser))
214       (null (package-use-list pused))
215       (null (package-use-list puser))
216       (eqt (let ((*package* puser)) (use-package pused)) t)  ;; user will use used
217       (multiple-value-bind (sym2 access)
218           (find-symbol "FOO" puser)
219         (and
220          (eqt access :inherited)
221          (eqt sym1 sym2)))
222       (equal (package-use-list puser) (list pused))
223       (equal (package-used-by-list pused) (list puser))
224       (null (package-use-list pused))
225       (null (package-used-by-list puser))
226       (eqt (unuse-package pused puser) t)
227       (null (find-symbol "FOO" puser)))))
228  t)
229
230;;; Tests for specialized sequence arguments
231
232(defmacro def-use-package-test (test-name &key (user "H") (used "G"))
233  `(deftest ,test-name
234     (let ((user-name ,user)
235           (used-name ,used))
236       (safely-delete-package user-name)
237       (safely-delete-package used-name)
238       (let* ((pused (make-package used-name :use nil))
239              (puser (make-package user-name :use nil))
240              (sym1 (intern "FOO" pused)))
241         (and
242          (eqt (export sym1 pused) t)
243          (null (package-used-by-list pused))
244          (null (package-used-by-list puser))
245          (null (package-use-list pused))
246          (null (package-use-list puser))
247          (eqt (let ((*package* puser)) (use-package pused)) t)  ;; user will use used
248          (multiple-value-bind (sym2 access)
249              (find-symbol "FOO" puser)
250            (and
251             (eqt access :inherited)
252             (eqt sym1 sym2)))
253          (equal (package-use-list puser) (list pused))
254          (equal (package-used-by-list pused) (list puser))
255          (null (package-use-list pused))
256          (null (package-used-by-list puser))
257          (eqt (unuse-package pused puser) t)
258          (null (find-symbol "FOO" puser)))))
259     t))
260
261;;; Specialized user package designator
262
263(def-use-package-test use-package.10
264  :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char))
265
266(def-use-package-test use-package.11
267  :user (make-array 10 :initial-contents "TEST1ABCDE"
268                    :fill-pointer 5 :element-type 'base-char))
269
270(def-use-package-test use-package.12
271  :user (make-array 10 :initial-contents "TEST1ABCDE"
272                    :fill-pointer 5 :element-type 'character))
273
274(def-use-package-test use-package.13
275  :user (make-array 5 :initial-contents "TEST1"
276                    :adjustable t :element-type 'base-char))
277
278(def-use-package-test use-package.14
279  :user (make-array 5 :initial-contents "TEST1"
280                    :adjustable t :element-type 'character))
281
282(def-use-package-test use-package.15
283  :user (let* ((etype 'base-char)
284               (name0 (make-array 10 :element-type etype
285                                  :initial-contents "xxxxxTEST1")))
286          (make-array 5 :element-type etype
287                      :displaced-to name0
288                      :displaced-index-offset 5)))
289
290(def-use-package-test use-package.16
291  :user
292  (let* ((etype 'character)
293         (name0 (make-array 10 :element-type etype
294                            :initial-contents "xxxxxTEST1")))
295    (make-array 5 :element-type etype
296                :displaced-to name0
297                :displaced-index-offset 5)))
298
299;;; Specialed used package designator
300
301(def-use-package-test use-package.17
302  :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char))
303
304(def-use-package-test use-package.18
305  :used (make-array 10 :initial-contents "TEST1ABCDE"
306                    :fill-pointer 5 :element-type 'base-char))
307
308(def-use-package-test use-package.19
309  :used (make-array 10 :initial-contents "TEST1ABCDE"
310                    :fill-pointer 5 :element-type 'character))
311
312(def-use-package-test use-package.20
313  :used (make-array 5 :initial-contents "TEST1"
314                    :adjustable t :element-type 'base-char))
315
316(def-use-package-test use-package.21
317  :used (make-array 5 :initial-contents "TEST1"
318                    :adjustable t :element-type 'character))
319
320(def-use-package-test use-package.22
321  :used (let* ((etype 'base-char)
322               (name0 (make-array 10 :element-type etype
323                                  :initial-contents "xxxxxTEST1")))
324          (make-array 5 :element-type etype
325                      :displaced-to name0
326                      :displaced-index-offset 5)))
327
328(def-use-package-test use-package.23
329  :used
330  (let* ((etype 'character)
331         (name0 (make-array 10 :element-type etype
332                            :initial-contents "xxxxxTEST1")))
333    (make-array 5 :element-type etype
334                :displaced-to name0
335                :displaced-index-offset 5)))
336
337(deftest use-package.error.1
338  (signals-error (use-package) program-error)
339  t)
340
341(deftest use-package.error.2
342  (progn
343    (safely-delete-package "UPE2A")
344    (safely-delete-package "UPE2")
345    (make-package "UPE2" :use ())
346    (make-package "UPE2A" :use ())
347    (signals-error (use-package "UPE2" "UPE2A" nil) program-error))
348  t)
Note: See TracBrowser for help on using the repository browser.