source: trunk/source/tests/ansi-tests/do-symbols.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 4.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Feb 21 18:24:59 2004
4;;;; Contains: Tests of DO-SYMBOLS
5
6(in-package :cl-test)
7
8(compile-and-load "package-aux.lsp")
9
10(declaim (optimize (safety 3)))
11
12(deftest do-symbols.1
13  (progn
14    (set-up-packages)
15    (equalt
16     (remove-duplicates
17      (sort-symbols (let ((all nil))
18                      (do-symbols (x "B" all) (push x all)))))
19     (list (find-symbol "BAR" "B")
20           (find-symbol "FOO" "A"))))
21  t)
22
23;;
24;; Test up some test packages
25;;
26
27(defun collect-symbols (pkg)
28  (remove-duplicates
29   (sort-symbols
30    (let ((all nil))
31      (do-symbols (x pkg all) (push x all))))))
32
33(deftest do-symbols.2
34  (collect-symbols "DS1")
35  (DS1:A DS1:B DS1::C DS1::D))
36
37(deftest do-symbols.3
38  (collect-symbols "DS2")
39  (DS2:A DS2::E DS2::F DS2:G DS2:H))
40
41(deftest do-symbols.4
42  (collect-symbols "DS3")
43  (DS1:A DS3:B DS2:G DS2:H DS3:I DS3:J DS3:K DS3::L DS3::M))
44
45(deftest do-symbols.5
46  (remove-duplicates
47   (collect-symbols "DS4")
48   :test #'(lambda (x y)
49             (and (eqt x y)
50                  (not (eqt x 'DS4::B)))))
51  (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z))
52
53
54;; Test that do-symbols works without
55;; a return value (and that the default return value is nil)
56
57(deftest do-symbols.6
58  (do-symbols (s "DS1") (declare (ignore s)) t)
59  nil)
60
61;; Test that do-symbols works without a package being specified
62
63(deftest do-symbols.7
64  (let ((x nil)
65        (*package* (find-package "DS1")))
66    (list
67     (do-symbols (s) (push s x))
68     (sort-symbols x)))
69  (nil (DS1:A DS1:B DS1::C DS1::D)))
70
71;; Test that the tags work in the tagbody,
72;;  and that multiple statements work
73
74(deftest do-symbols.8
75  (handler-case
76   (let ((x nil))
77     (list
78      (do-symbols
79       (s "DS1")
80       (when (equalt (symbol-name s) "C") (go bar))
81       (push s x)
82       (go foo)
83       bar
84       (push t x)
85       foo)
86      (sort-symbols x)))
87   (error (c) c))
88  (NIL (DS1:A DS1:B DS1::D T)))
89
90;;; Specialized sequences
91
92(defmacro def-do-symbols-test (test-name name-form)
93  `(deftest ,test-name
94     (let ((name ,name-form))
95       (assert (string= name "B"))
96       (set-up-packages)
97       (equalt
98        (remove-duplicates
99         (sort-symbols (let ((all nil))
100                         (do-symbols (x name all) (push x all)))))
101        (list (find-symbol "BAR" "B")
102              (find-symbol "FOO" "A"))))
103     t))
104
105(def-do-symbols-test do-symbols.9
106  (make-array 1 :element-type 'base-char :initial-contents "B"))
107
108(def-do-symbols-test do-symbols.10
109  (make-array 5 :element-type 'character
110              :fill-pointer 1
111              :initial-contents "BXXXX"))
112
113(def-do-symbols-test do-symbols.11
114  (make-array 5 :element-type 'base-char
115              :fill-pointer 1
116              :initial-contents "BXXXX"))
117
118(def-do-symbols-test do-symbols.12
119  (make-array 1 :element-type 'base-char
120              :adjustable t :initial-contents "B"))
121
122(def-do-symbols-test do-symbols.13
123  (make-array 1 :element-type 'character
124              :adjustable t :initial-contents "B"))
125
126(def-do-symbols-test do-symbols.14
127  (let* ((etype 'base-char)
128         (name0 (make-array 4 :element-type etype :initial-contents "XBYZ")))
129    (make-array 1 :element-type etype
130                :displaced-to name0 :displaced-index-offset 1)))
131
132(def-do-symbols-test do-symbols.15
133  (let* ((etype 'character)
134         (name0 (make-array 4 :element-type etype :initial-contents "XBYZ")))
135    (make-array 1 :element-type etype
136                :displaced-to name0 :displaced-index-offset 1)))
137
138;;; Free declaration scope tests
139
140(deftest do-symbols.16
141  (block done
142    (let ((x :bad))
143      (declare (special x))
144      (let ((x :good))
145        (do-symbols (s (return-from done x))
146          (declare (special x))))))
147  :good)
148
149(deftest do-symbols.17
150  (let ((x :good))
151    (declare (special x))
152    (let ((x :bad))
153      (do-symbols (s "CL-TEST" x)
154        (declare (special x)))))
155  :good)
156
157;;; Test that explicit calls to macroexpand in subforms
158;;; are done in the correct environment
159
160(deftest do-symbols.18
161  (macrolet
162   ((%m (z) z))
163   (do-symbols (s (expand-in-current-env (%m "CL-TEST")) :good)))
164  :good)
165
166(deftest do-symbols.19
167  (macrolet
168   ((%m (z) z))
169   (do-symbols (s "CL-TEST" (expand-in-current-env (%m :good)))))
170  :good)
171
172(def-macro-test do-symbols.error.1
173  (do-symbols (x "CL")))
Note: See TracBrowser for help on using the repository browser.