do-external-symbols.lsp 3.99 KB
Newer Older
1
2
3
4
5
6
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Feb 21 18:26:08 2004
;;;; Contains: Tests of DO-EXTERNAL-SYMBOLS

(in-package :cl-test)
7
8
9

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

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
(declaim (optimize (safety 3)))

(defun collect-external-symbols (pkg)
  (remove-duplicates
   (sort-symbols
    (let ((all nil))
      (do-external-symbols (x pkg all) (push x all))))))

(deftest do-external-symbols.1
    (collect-external-symbols "DS1")
  (DS1:A DS1:B))

(deftest do-external-symbols.2
    (collect-external-symbols "DS2")
  (DS2:A DS2:G DS2:H))

(deftest do-external-symbols.3
    (collect-external-symbols "DS3")
  (DS1:A DS3:B DS2:G DS3:I DS3:J DS3:K))

(deftest do-external-symbols.4
    (collect-external-symbols "DS4")
  ())

(deftest do-external-symbols.5
    (equalt (collect-external-symbols "KEYWORD")
sds's avatar
sds committed
36
            (collect-symbols "KEYWORD"))
37
38
39
40
41
42
43
44
45
46
47
48
49
50
  t)

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

(deftest do-external-symbols.6
  (do-external-symbols (s "DS1") (declare (ignore s)) t)
  nil)

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

(deftest do-external-symbols.7
  (let ((x nil)
sds's avatar
sds committed
51
        (*package* (find-package "DS1")))
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
    (list
     (do-external-symbols (s) (push s x))
     (sort-symbols x)))
  (nil (DS1:A DS1:B)))

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

(deftest do-external-symbols.8
  (handler-case
   (let ((x nil))
     (list
      (do-external-symbols
       (s "DS1")
       (when (equalt (symbol-name s) "A") (go bar))
       (push s x)
       (go foo)
       bar
       (push t x)
       foo)
      (sort-symbols x)))
   (error (c) c))
  (NIL (DS1:B T)))

76
77
78
79
80
81
82
83
84
85
86
87
;;; Specialized sequence tests

(defmacro def-do-external-symbols-test (test-name name-form)
  `(deftest ,test-name
     (collect-external-symbols ,name-form)
     (DS1:A DS1:B)))

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

(def-do-external-symbols-test do-external-symbols.10
  (make-array 6 :element-type 'base-char :initial-contents "DS1XXX"
sds's avatar
sds committed
88
              :fill-pointer 3))
89
90
91

(def-do-external-symbols-test do-external-symbols.11
  (make-array 6 :element-type 'character :initial-contents "DS1XXX"
sds's avatar
sds committed
92
              :fill-pointer 3))
93
94
95

(def-do-external-symbols-test do-external-symbols.12
  (make-array 3 :element-type 'base-char :initial-contents "DS1"
sds's avatar
sds committed
96
              :adjustable t))
97
98
99

(def-do-external-symbols-test do-external-symbols.13
  (make-array 3 :element-type 'character :initial-contents "DS1"
sds's avatar
sds committed
100
              :adjustable t))
101
102
103

(def-do-external-symbols-test do-external-symbols.14
  (let* ((etype 'base-char)
sds's avatar
sds committed
104
         (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX")))
105
    (make-array 3 :element-type etype
sds's avatar
sds committed
106
                :displaced-to name0 :displaced-index-offset 1)))
107
108
109

(def-do-external-symbols-test do-external-symbols.15
  (let* ((etype 'character)
sds's avatar
sds committed
110
         (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX")))
111
    (make-array 3 :element-type etype
sds's avatar
sds committed
112
                :displaced-to name0 :displaced-index-offset 1)))
113

114
115
116
117
118
119
120
;;; Free declaration scope tests

(deftest do-external-symbols.16
  (block done
    (let ((x :bad))
      (declare (special x))
      (let ((x :good))
sds's avatar
sds committed
121
122
        (do-external-symbols (s (return-from done x))
          (declare (special x))))))
123
124
125
126
127
128
129
  :good)

(deftest do-external-symbols.17
  (let ((x :good))
    (declare (special x))
    (let ((x :bad))
      (do-external-symbols (s "CL-TEST" x)
sds's avatar
sds committed
130
        (declare (special x)))))
131
132
  :good)

133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment

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

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

148
149
;;; Error tests

150
(def-macro-test do-external-symbols.error.1
sds's avatar
sds committed
151
  (do-external-symbols (x "CL")))