shadow.lsp 9.4 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:01:20 1998
4
;;;; Contains: Tests of SHADOW
5

6

7 8 9 10 11
(declaim (optimize (safety 3)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; shadow

12
(deftest shadow.1
13 14
  (prog1
      (progn
sds's avatar
sds committed
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
        (safely-delete-package "TEST5")
        (safely-delete-package "TEST4")
        (handler-case
         (let* ((p1 (prog1
                        (make-package "TEST4" :use nil)
                      (export (intern "A" "TEST4") "TEST4")))
                (p2 (make-package "TEST5" :use '("TEST4")))
                (r1 (package-shadowing-symbols "TEST4"))
                (r2 (package-shadowing-symbols "TEST5")))
           (multiple-value-bind* (s1 kind1)
               (find-symbol "A" p1)
             (multiple-value-bind* (s2 kind2)
                 (find-symbol "A" p2)
               (let ((r3 (shadow "A" p2)))
                 (multiple-value-bind* (s3 kind3)
                     (find-symbol "A" p2)
                   (list
                    (package-name p1)
                    (package-name p2)
                    r1 r2
                    (symbol-name s1)
                    (package-name (symbol-package s1))
                    kind1
                    (symbol-name s2)
                    (package-name (symbol-package s2))
                    kind2
                    r3
                    (symbol-name s3)
                    (package-name (symbol-package s3))
                    kind3))))))
         (error (c) c)))
46 47
    (safely-delete-package "TEST5")
    (safely-delete-package "TEST4"))
48
  ("TEST4" "TEST5" nil nil "A" "TEST4" :external
49 50 51
   "A" "TEST4" :inherited
   t
   "A" "TEST5" :internal))
52

53
(deftest shadow.2
54 55 56 57 58
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (handler-case
     (let* ((p1 (prog1
sds's avatar
sds committed
59 60 61 62 63
                    (make-package "G" :use nil)
                  (export (intern "A" "G") "G")))
            (p2 (make-package "H" :use '("G")))
            (r1 (package-shadowing-symbols "G"))
            (r2 (package-shadowing-symbols "H")))
64
       (multiple-value-bind* (s1 kind1)
sds's avatar
sds committed
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
           (find-symbol "A" p1)
         (multiple-value-bind* (s2 kind2)
             (find-symbol "A" p2)
           (let ((r3 (shadow "A" "H")))
             (multiple-value-bind* (s3 kind3)
                 (find-symbol "A" p2)
               (prog1
                   (list (package-name p1) (package-name p2)
                         r1 r2 (symbol-name s1) (package-name (symbol-package s1))
                         kind1 (symbol-name s2) (package-name (symbol-package s2))
                         kind2 r3 (symbol-name s3) (package-name (symbol-package s3))
                         kind3)
                 (safely-delete-package p2)
                 (safely-delete-package p1)
                 ))))))
80
     (error (c)
sds's avatar
sds committed
81 82 83
            (safely-delete-package "H")
            (safely-delete-package "G")
            c)))
84
  ("G" "H" nil nil "A" "G" :external
85 86 87
   "A" "G" :inherited
   t
   "A" "H" :internal))
88 89 90

;; shadow in which the package is given
;; by a character
91
(deftest shadow.3
92 93 94 95 96
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (handler-case
     (let* ((p1 (prog1
sds's avatar
sds committed
97 98 99 100 101
                    (make-package "G" :use nil)
                  (export (intern "A" "G") "G")))
            (p2 (make-package "H" :use '("G")))
            (r1 (package-shadowing-symbols "G"))
            (r2 (package-shadowing-symbols "H")))
102
       (multiple-value-bind* (s1 kind1)
sds's avatar
sds committed
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
           (find-symbol "A" p1)
         (multiple-value-bind* (s2 kind2)
             (find-symbol "A" p2)
           (let ((r3 (shadow "A" #\H)))
             (multiple-value-bind* (s3 kind3)
                 (find-symbol "A" p2)
               (prog1
                   (list (package-name p1) (package-name p2)
                         r1 r2 (symbol-name s1) (package-name (symbol-package s1))
                         kind1 (symbol-name s2) (package-name (symbol-package s2))
                         kind2 r3 (symbol-name s3) (package-name (symbol-package s3))
                         kind3)
                 (safely-delete-package p2)
                 (safely-delete-package p1)
                 ))))))
118
     (error (c)
sds's avatar
sds committed
119 120 121
            (safely-delete-package "H")
            (safely-delete-package "G")
            c)))
122
  ("G" "H" nil nil "A" "G" :external
123 124 125
   "A" "G" :inherited
   t
   "A" "H" :internal))
126 127 128


;; shadow on an existing internal symbol returns the existing symbol
129
(deftest shadow.4
130 131 132
  (prog1
      (handler-case
       (progn
sds's avatar
sds committed
133 134 135 136 137 138 139 140 141 142
         (safely-delete-package :G)
         (make-package :G :use nil)
         (let ((s1 (intern "X" :G)))
           (shadow "X" :G)
           (multiple-value-bind* (s2 kind)
               (find-symbol "X" :G)
             (list (eqt s1 s2)
                   (symbol-name s2)
                   (package-name (symbol-package s2))
                   kind))))
143 144
       (error (c) c))
    (safely-delete-package "G"))
145 146 147 148
  (t "X" "G" :internal))


;; shadow of an existing shadowed symbol returns the symbol
149
(deftest shadow.5
150 151 152
  (prog1
      (handler-case
       (progn
sds's avatar
sds committed
153 154 155 156 157 158 159 160 161 162 163 164
         (safely-delete-package :H)
         (safely-delete-package :G)
         (make-package :G :use nil)
         (export (intern "X" :G) :G)
         (make-package :H :use '("G"))
         (shadow "X" :H)
         (multiple-value-bind* (s1 kind1)
             (find-symbol "X" :H)
           (shadow "X" :H)
           (multiple-value-bind* (s2 kind2)
               (find-symbol "X" :H)
             (list (eqt s1 s2) kind1 kind2))))
165 166 167
       (error (c) c))
    (safely-delete-package :H)
    (safely-delete-package :G))
168 169 170 171
  (t :internal :internal))

;; Shadow several names simultaneously

172
(deftest shadow.6
173 174 175
  (prog1
      (handler-case
       (progn
sds's avatar
sds committed
176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
         (safely-delete-package :G)
         (make-package :G :use nil)
         (shadow '("X" "Y" |Z|) :G)
         (let ((results
                (append (multiple-value-list
                         (find-symbol "X" :G))
                        (multiple-value-list
                         (find-symbol "Y" :G))
                        (multiple-value-list
                         (find-symbol "Z" :G))
                        nil)))
           (list
            (symbol-name (first results))
            (second results)
            (symbol-name (third results))
            (fourth results)
            (symbol-name (fifth results))
            (sixth results)
            (length (package-shadowing-symbols :G)))))
195 196
       (error (c) c))
    (safely-delete-package :G))
197 198 199
  ("X" :internal "Y" :internal "Z" :internal 3))

;; Same, but shadow character string designators
200
(deftest shadow.7
201 202
  (prog1
      (handler-case
203
       (let ((i 0) x y)
sds's avatar
sds committed
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
         (safely-delete-package :G)
         (make-package :G :use nil)
         (shadow (progn (setf x (incf i)) '(#\X #\Y))
                 (progn (setf y (incf i)) :G))
         (let ((results
                (append (multiple-value-list
                         (find-symbol "X" :G))
                        (multiple-value-list
                         (find-symbol "Y" :G))
                        nil)))
           (list
            i x y
            (symbol-name (first results))
            (second results)
            (symbol-name (third results))
            (fourth results)
            (length (package-shadowing-symbols :G)))))
221 222
       (error (c) c))
    (safely-delete-package :G))
223
  (2 1 2 "X" :internal "Y" :internal 2))
224

225 226 227 228 229 230
;;; Specialized string tests

(deftest shadow.8
  (prog1
      (handler-case
       (progn
sds's avatar
sds committed
231 232 233 234 235 236 237 238 239 240 241 242
         (safely-delete-package :G)
         (make-package :G :use nil)
         (let* ((name (make-array '(1) :initial-contents "X"
                                  :element-type 'base-char))
                (s1 (intern name :G)))
           (shadow name :G)
           (multiple-value-bind* (s2 kind)
               (find-symbol "X" :G)
             (list (eqt s1 s2)
                   (symbol-name s2)
                   (package-name (symbol-package s2))
                   kind))))
243 244 245 246 247 248 249 250
       (error (c) c))
    (safely-delete-package "G"))
  (t "X" "G" :internal))

(deftest shadow.9
  (prog1
      (handler-case
       (progn
sds's avatar
sds committed
251 252 253 254 255 256 257 258 259 260 261 262 263
         (safely-delete-package :G)
         (make-package :G :use nil)
         (let* ((name (make-array '(3) :initial-contents "XYZ"
                                  :fill-pointer 1
                                  :element-type 'character))
                (s1 (intern name :G)))
           (shadow name :G)
           (multiple-value-bind* (s2 kind)
               (find-symbol "X" :G)
             (list (eqt s1 s2)
                   (symbol-name s2)
                   (package-name (symbol-package s2))
                   kind))))
264 265 266 267 268 269 270 271
       (error (c) c))
    (safely-delete-package "G"))
  (t "X" "G" :internal))

(deftest shadow.10
  (prog1
      (handler-case
       (progn
sds's avatar
sds committed
272 273 274 275 276 277 278 279 280 281 282 283 284
         (safely-delete-package :G)
         (make-package :G :use nil)
         (let* ((name (make-array '(1) :initial-contents "X"
                                  :adjustable t
                                  :element-type 'base-char))
                (s1 (intern name :G)))
           (shadow name :G)
           (multiple-value-bind* (s2 kind)
               (find-symbol "X" :G)
             (list (eqt s1 s2)
                   (symbol-name s2)
                   (package-name (symbol-package s2))
                   kind))))
285 286 287 288 289 290 291
       (error (c) c))
    (safely-delete-package "G"))
  (t "X" "G" :internal))




292
(deftest shadow.error.1
293 294
  (signals-error (shadow) program-error)
  t)
295 296

(deftest shadow.error.2
297 298
  (signals-error (shadow "X" "CL-USER" nil) program-error)
  t)