with-package-iterator.lsp 4.93 KB
Newer Older
1
2
3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:03:36 1998
4
;;;; Contains: Tests of WITH-PACKAGE-ITERATOR
5
6
7
8

(in-package :cl-test)
(declaim (optimize (safety 3)))

9
(compile-and-load "package-aux.lsp")
10

11
12
13
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; with-package-iterator

14
15
(deftest with-package-iterator.1
  (with-package-iterator-internal (list (find-package "COMMON-LISP-USER")))
16
17
  t)

18
19
(deftest with-package-iterator.2
  (with-package-iterator-external (list (find-package "COMMON-LISP-USER")))
20
21
  t)

22
23
(deftest with-package-iterator.3
  (with-package-iterator-inherited (list (find-package "COMMON-LISP-USER")))
24
25
  t)

26
27
(deftest with-package-iterator.4
  (with-package-iterator-all (list (find-package "COMMON-LISP-USER")))
28
29
  t)

30
31
;;; Should test on some packages containing shadowed symbols,
;;; multiple inheritance
32

33
(deftest with-package-iterator.5
pfdietz's avatar
pfdietz committed
34
35
36
  (progn
    (set-up-packages)
    (with-package-iterator-all '("A")))
37
38
  t)

39
(deftest with-package-iterator.6
pfdietz's avatar
pfdietz committed
40
41
42
  (progn
    (set-up-packages)
    (with-package-iterator-all '(#:|A|)))
43
44
  t)

45
(deftest with-package-iterator.7
pfdietz's avatar
pfdietz committed
46
47
48
  (progn
    (set-up-packages)
    (with-package-iterator-all '(#\A)))
49
50
  t)

51
(deftest with-package-iterator.8
pfdietz's avatar
pfdietz committed
52
53
54
  (progn
    (set-up-packages)
    (with-package-iterator-internal (list (find-package "A"))))
55
56
  t)

57
(deftest with-package-iterator.9
pfdietz's avatar
pfdietz committed
58
59
60
  (progn
    (set-up-packages)
    (with-package-iterator-external (list (find-package "A"))))
61
62
  t)

63
(deftest with-package-iterator.10
pfdietz's avatar
pfdietz committed
64
65
66
  (progn
    (set-up-packages)
    (with-package-iterator-inherited (list (find-package "A"))))
67
68
  t)

69
(deftest with-package-iterator.11
sds's avatar
sds committed
70
  (signals-error
71
72
   (with-package-iterator (x "COMMON-LISP-USER"))
   program-error)
73
74
  t)

75
;;; Apply to all packages
76
77
78
79
80
81
82
83
(deftest with-package-iterator.12
  (loop
   for p in (list-all-packages) count
   (handler-case
    (progn
      (format t "Package ~S~%" p)
      (not (with-package-iterator-internal (list p))))
    (error (c)
sds's avatar
sds committed
84
85
           (format "Error ~S on package ~A~%" c p)
           t)))
86
87
  0)

88
89
90
91
92
93
94
95
(deftest with-package-iterator.13
  (loop
   for p in (list-all-packages) count
   (handler-case
    (progn
      (format t "Package ~S~%" p)
      (not (with-package-iterator-external (list p))))
    (error (c)
sds's avatar
sds committed
96
97
           (format "Error ~S on package ~A~%" c p)
           t)))
98
99
  0)

100
101
102
103
104
105
106
107
(deftest with-package-iterator.14
  (loop
   for p in (list-all-packages) count
   (handler-case
    (progn
      (format t "Package ~S~%" p)
      (not (with-package-iterator-inherited (list p))))
    (error (c)
sds's avatar
sds committed
108
109
           (format t "Error ~S on package ~S~%" c p)
           t)))
110
  0)
111
112
113

(def-macro-test with-package-iterator.error.1
  (with-package-iterator (x "CL" :external) nil))
114
115
116
117
118
119
120
121
122


;;; Specialized sequence tests

(defmacro def-with-package-iterator-test (test-name name-form)
  `(deftest ,test-name
     (let ((name ,name-form))
       (safely-delete-package name)
       (let* ((p (make-package name :use nil))
sds's avatar
sds committed
123
124
125
126
127
128
129
130
131
132
133
134
              (result nil)
              (s (intern "X" p)))
         (with-package-iterator
          (x name :internal)
          (loop
           (multiple-value-bind
               (good? sym)
               (x)
               (unless good?
                 (safely-delete-package name)
                 (return (equalt (list s) result)))
             (push sym result))))))
135
136
137
138
     t))

(def-with-package-iterator-test with-package-iterator.15
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
139
              :element-type 'base-char))
140
141
142

(def-with-package-iterator-test with-package-iterator.16
  (make-array 8 :initial-contents "TEST1XXX"
sds's avatar
sds committed
143
144
              :fill-pointer 5
              :element-type 'base-char))
145
146
147

(def-with-package-iterator-test with-package-iterator.17
  (make-array 8 :initial-contents "TEST1XXX"
sds's avatar
sds committed
148
149
              :fill-pointer 5
              :element-type 'character))
150
151
152

(def-with-package-iterator-test with-package-iterator.18
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
153
154
              :adjustable t
              :element-type 'base-char))
155
156
157

(def-with-package-iterator-test with-package-iterator.19
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
158
159
              :adjustable t
              :element-type 'character))
160
161
162

(def-with-package-iterator-test with-package-iterator.20
  (let* ((etype 'base-char)
sds's avatar
sds committed
163
164
         (name0 (make-array 10 :initial-contents "XTEST1YzYY"
                            :element-type etype)))
165
    (make-array 5 :element-type etype
sds's avatar
sds committed
166
167
                :displaced-to name0
                :displaced-index-offset 1)))
168
169
170

(def-with-package-iterator-test with-package-iterator.21
  (let* ((etype 'character)
sds's avatar
sds committed
171
172
         (name0 (make-array 10 :initial-contents "XTEST1YzYY"
                            :element-type etype)))
173
    (make-array 5 :element-type etype
sds's avatar
sds committed
174
175
                :displaced-to name0
                :displaced-index-offset 1)))
176
177
178
179
180
181
182
183

;;; Free declaration scope

(deftest with-package-iterator.22
  (block done
    (let ((x :bad))
      (declare (special x))
      (let ((x :good))
sds's avatar
sds committed
184
185
        (with-package-iterator (s (return-from done x) :internal)
                               (declare (special x))))))
186
  :good)