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)