do-symbols.lsp 4.22 KB
Newer Older
1 2
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
3 4
;;;; Created:  Sat Feb 21 18:24:59 2004
;;;; Contains: Tests of DO-SYMBOLS
5

6

7

8

9

10 11
(declaim (optimize (safety 3)))

12
(deftest do-symbols.1
13 14 15 16 17
  (progn
    (set-up-packages)
    (equalt
     (remove-duplicates
      (sort-symbols (let ((all nil))
sds's avatar
sds committed
18
                      (do-symbols (x "B" all) (push x all)))))
19
     (list (find-symbol "BAR" "B")
sds's avatar
sds committed
20
           (find-symbol "FOO" "A"))))
21 22 23 24 25 26 27
  t)

;;
;; Test up some test packages
;;

(defun collect-symbols (pkg)
28 29 30 31
  (remove-duplicates
   (sort-symbols
    (let ((all nil))
      (do-symbols (x pkg all) (push x all))))))
32

33
(deftest do-symbols.2
34
  (collect-symbols "DS1")
35 36
  (DS1:A DS1:B DS1::C DS1::D))

37
(deftest do-symbols.3
38
  (collect-symbols "DS2")
39 40
  (DS2:A DS2::E DS2::F DS2:G DS2:H))

41
(deftest do-symbols.4
42
  (collect-symbols "DS3")
43 44
  (DS1:A DS3:B DS2:G DS2:H DS3:I DS3:J DS3:K DS3::L DS3::M))

45
(deftest do-symbols.5
46 47 48
  (remove-duplicates
   (collect-symbols "DS4")
   :test #'(lambda (x y)
sds's avatar
sds committed
49 50
             (and (eqt x y)
                  (not (eqt x 'DS4::B)))))
51 52 53
  (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z))


54
;; Test that do-symbols works without
55 56
;; a return value (and that the default return value is nil)

57
(deftest do-symbols.6
58
  (do-symbols (s "DS1") (declare (ignore s)) t)
59 60
  nil)

61
;; Test that do-symbols works without a package being specified
62

63
(deftest do-symbols.7
64
  (let ((x nil)
sds's avatar
sds committed
65
        (*package* (find-package "DS1")))
66 67 68 69 70 71 72 73
    (list
     (do-symbols (s) (push s x))
     (sort-symbols x)))
  (nil (DS1:A DS1:B DS1::C DS1::D)))

;; Test that the tags work in the tagbody,
;;  and that multiple statements work

74
(deftest do-symbols.8
75 76 77 78 79
  (handler-case
   (let ((x nil))
     (list
      (do-symbols
       (s "DS1")
80
       (when (equalt (symbol-name s) "C") (go bar))
81 82 83
       (push s x)
       (go foo)
       bar
84
       (push t x)
85 86 87 88 89
       foo)
      (sort-symbols x)))
   (error (c) c))
  (NIL (DS1:A DS1:B DS1::D T)))

90 91 92 93 94 95
;;; Specialized sequences

(defmacro def-do-symbols-test (test-name name-form)
  `(deftest ,test-name
     (let ((name ,name-form))
       (assert (string= name "B"))
96
       (set-up-packages)
97
       (equalt
sds's avatar
sds committed
98 99 100 101 102
        (remove-duplicates
         (sort-symbols (let ((all nil))
                         (do-symbols (x name all) (push x all)))))
        (list (find-symbol "BAR" "B")
              (find-symbol "FOO" "A"))))
103 104 105 106 107 108 109
     t))

(def-do-symbols-test do-symbols.9
  (make-array 1 :element-type 'base-char :initial-contents "B"))

(def-do-symbols-test do-symbols.10
  (make-array 5 :element-type 'character
sds's avatar
sds committed
110 111
              :fill-pointer 1
              :initial-contents "BXXXX"))
112 113 114

(def-do-symbols-test do-symbols.11
  (make-array 5 :element-type 'base-char
sds's avatar
sds committed
115 116
              :fill-pointer 1
              :initial-contents "BXXXX"))
117 118 119

(def-do-symbols-test do-symbols.12
  (make-array 1 :element-type 'base-char
sds's avatar
sds committed
120
              :adjustable t :initial-contents "B"))
121 122 123

(def-do-symbols-test do-symbols.13
  (make-array 1 :element-type 'character
sds's avatar
sds committed
124
              :adjustable t :initial-contents "B"))
125 126 127

(def-do-symbols-test do-symbols.14
  (let* ((etype 'base-char)
sds's avatar
sds committed
128
         (name0 (make-array 4 :element-type etype :initial-contents "XBYZ")))
129
    (make-array 1 :element-type etype
sds's avatar
sds committed
130
                :displaced-to name0 :displaced-index-offset 1)))
131 132 133

(def-do-symbols-test do-symbols.15
  (let* ((etype 'character)
sds's avatar
sds committed
134
         (name0 (make-array 4 :element-type etype :initial-contents "XBYZ")))
135
    (make-array 1 :element-type etype
sds's avatar
sds committed
136
                :displaced-to name0 :displaced-index-offset 1)))
137

138 139 140 141 142 143 144
;;; Free declaration scope tests

(deftest do-symbols.16
  (block done
    (let ((x :bad))
      (declare (special x))
      (let ((x :good))
sds's avatar
sds committed
145 146
        (do-symbols (s (return-from done x))
          (declare (special x))))))
147 148 149 150 151 152 153
  :good)

(deftest do-symbols.17
  (let ((x :good))
    (declare (special x))
    (let ((x :bad))
      (do-symbols (s "CL-TEST" x)
sds's avatar
sds committed
154
        (declare (special x)))))
155
  :good)
156

157 158 159 160 161 162 163 164 165 166 167 168 169 170 171
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment

(deftest do-symbols.18
  (macrolet
   ((%m (z) z))
   (do-symbols (s (expand-in-current-env (%m "CL-TEST")) :good)))
  :good)

(deftest do-symbols.19
  (macrolet
   ((%m (z) z))
   (do-symbols (s "CL-TEST" (expand-in-current-env (%m :good)))))
  :good)

172 173
(def-macro-test do-symbols.error.1
  (do-symbols (x "CL")))