unintern.lsp 9.24 KB
Newer Older
1
();-*- Mode:     Lisp -*-
2 3
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:04:56 1998
4
;;;; Contains: Tests of UNINTERN
5 6 7 8 9 10 11 12 13

(in-package :cl-test)
(declaim (optimize (safety 3)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; unintern

;; Simple unintern of an internal symbol, package explicitly
;; given as a package object
14
(deftest unintern.1
15 16 17
  (progn
    (safely-delete-package "H")
    (prog1
sds's avatar
sds committed
18 19 20 21 22 23 24 25 26 27 28 29 30
        (let ((p (make-package "H" :use nil))
              (i 0) x y)
          (intern "FOO" p)
          (multiple-value-bind*
           (sym access)
           (find-symbol "FOO" p)
           (and
            (eqt access :internal)
            (unintern (progn (setf x (incf i)) sym)
                      (progn (setf y (incf i)) p))
            (eql i 2) (eql x 1) (eql y 2)
            (null (symbol-package sym))
            (not (find-symbol "FOO" p)))))
31
      (safely-delete-package "H")))
32 33 34 35
  t)

;; Simple unintern, package taken from the *PACKAGES*
;; special variable (should this have unwind protect?)
36
(deftest unintern.2
37 38 39
  (progn
    (safely-delete-package "H")
    (prog1
sds's avatar
sds committed
40 41 42 43 44 45 46 47 48
        (let ((*PACKAGE* (make-package "H" :use nil)))
          (intern "FOO")
          (multiple-value-bind* (sym access)
              (find-symbol "FOO")
            (and
             (eqt access :internal)
             (unintern sym)
             (null (symbol-package sym))
             (not (find-symbol "FOO")))))
49
      (safely-delete-package "H")))
50 51 52
  t)

;; Simple unintern, package given as string
53
(deftest unintern.3
54 55 56
  (progn
    (safely-delete-package "H")
    (prog1
sds's avatar
sds committed
57 58 59 60 61 62 63 64 65
        (let ((p (make-package "H" :use nil)))
          (intern "FOO" p)
          (multiple-value-bind* (sym access)
              (find-symbol "FOO" p)
            (and
             (eqt access :internal)
             (unintern sym "H")
             (null (symbol-package sym))
             (not (find-symbol "FOO" p)))))
66
      (safely-delete-package "H")))
67 68 69
  t)

;; Simple unintern, package given as symbol
70
(deftest unintern.4
71 72 73
  (progn
    (safely-delete-package "H")
    (prog1
sds's avatar
sds committed
74 75 76 77 78 79 80 81 82
        (let ((p (make-package "H" :use nil)))
          (intern "FOO" p)
          (multiple-value-bind* (sym access)
              (find-symbol "FOO" p)
            (and
             (eqt access :internal)
             (unintern sym '#:|H|)
             (null (symbol-package sym))
             (not (find-symbol "FOO" p)))))
83
      (safely-delete-package "H")))
84 85 86
  t)

;; Simple unintern, package given as character
87
(deftest unintern.5
88 89 90 91
  (handler-case
   (progn
     (safely-delete-package "H")
     (prog1
sds's avatar
sds committed
92 93 94 95 96 97 98 99 100
         (let ((p (make-package "H" :use nil)))
           (intern "FOO" p)
           (multiple-value-bind* (sym access)
               (find-symbol "FOO" p)
             (and
              (eqt access :internal)
              (unintern sym #\H)
              (null (symbol-package sym))
              (not (find-symbol "FOO" p)))))
101 102
       (safely-delete-package "H")))
   (error (c) c))
103 104 105 106 107 108 109
  t)


;; Test more complex examples of unintern

;; Unintern an external symbol that is also inherited

110
(deftest unintern.6
111 112 113 114
  (handler-case
   (progn
     (safely-delete-package "H")
     (safely-delete-package "G")
115
     (make-package "G" :use nil)
116 117 118 119 120
     (export (intern "FOO" "G") "G")
     (make-package "H" :use '("G"))
     (export (intern "FOO" "H") "H")
     ;; At this point, G:FOO is also an external
     ;; symbol of H.
121
     (multiple-value-bind* (sym1 access1)
sds's avatar
sds committed
122
         (find-symbol "FOO" "H")
123
       (and sym1
sds's avatar
sds committed
124 125 126 127 128 129 130 131 132 133 134
            (eqt access1 :external)
            (equal "FOO" (symbol-name sym1))
            (eqt (find-package "G")
                 (symbol-package sym1))
            (unintern sym1 "H")
            (multiple-value-bind* (sym2 access2)
                (find-symbol "FOO" "H")
              (and (eqt sym1 sym2)
                   (eqt (symbol-package sym1)
                        (find-package "G"))
                   (eqt access2 :inherited))))))
135
   (error (c) c))
136 137 138 139
  t)

;; unintern a symbol that is shadowing another symbol

140
(deftest unintern.7
141
    (block failed
142 143
      (safely-delete-package "H")
      (safely-delete-package "G")
144
      (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
             (ph (make-package "H" :use (list pg))))
        (handler-case
           (shadow "FOO" ph)
           (error (c) (return-from failed (list :shadow-error c))))
        (export (intern "FOO" pg) pg)
        ;; At this point, H::FOO shadows G:FOO
        (multiple-value-bind* (sym1 access1)
            (find-symbol "FOO" ph)
          (and
           sym1
           (eqt (symbol-package sym1) ph)
           (eqt access1 :internal)
           (equal (list sym1) (package-shadowing-symbols ph))
           (unintern sym1 ph)
           (multiple-value-bind* (sym2 access2)
               (find-symbol "FOO" ph)
             (and (not (eqt sym1 sym2))
                  (eqt access2 :inherited)
                  (null (symbol-package sym1))
                  (eqt (symbol-package sym2) pg)))))))
165 166 167 168
  t)

;; Error situation: when the symbol is uninterned, creates
;; a name conflict from two used packages
169
(deftest unintern.8
170
  (block failed
171 172 173
    (safely-delete-package "H")
    (safely-delete-package "G1")
    (safely-delete-package "G2")
174
    (let* ((pg1 (make-package "G1" :use nil))
sds's avatar
sds committed
175 176
           (pg2 (make-package "G2" :use nil))
           (ph (make-package "H" :use (list pg1 pg2))))
177 178 179 180
      (handler-case
       (shadow "FOO" ph)
       (error (c) (return-from failed (list :shadow-error c))))
      (let ((gsym1 (intern "FOO" pg1))
sds's avatar
sds committed
181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
            (gsym2 (intern "FOO" pg2)))
        (export gsym1 pg1)
        (export gsym2 pg2)
        (multiple-value-bind* (sym1 access1)
            (find-symbol "FOO" ph)
          (and
           (equal (list sym1) (package-shadowing-symbols ph))
           (not (eqt sym1 gsym1))
           (not (eqt sym1 gsym2))
           (eqt (symbol-package sym1) ph)
           (eqt access1 :internal)
           (equal (symbol-name sym1) "FOO")
           (handler-case
            (progn
              (unintern sym1 ph)
              nil)
            (error (c)
                   (format t "Properly threw an error: ~S~%" c)
                   t)))))))
200 201 202 203 204
  t)

;; Now, inherit the same symbol through two intermediate
;; packages.  No error should occur when the shadowing
;; is removed
205
(deftest unintern.9
206
  (block failed
207 208 209 210
    (safely-delete-package "H")
    (safely-delete-package "G1")
    (safely-delete-package "G2")
    (safely-delete-package "G3")
211
    (let* ((pg3 (make-package "G3" :use nil))
sds's avatar
sds committed
212 213 214
           (pg1 (make-package "G1" :use (list pg3)))
           (pg2 (make-package "G2" :use (list pg3)))
           (ph  (make-package "H"  :use (list pg1 pg2))))
215 216 217 218
      (handler-case
       (shadow "FOO" ph)
       (error (c) (return-from failed (list :shadow-error c))))
      (let ((gsym (intern "FOO" pg3)))
sds's avatar
sds committed
219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236
        (export gsym pg3)
        (export gsym pg1)
        (export gsym pg2)
        (multiple-value-bind* (sym access)
            (find-symbol "FOO" ph)
          (and
           (equal (list sym) (package-shadowing-symbols ph))
           (not (eqt sym gsym))
           (equal (symbol-name sym) "FOO")
           (equal (symbol-package sym) ph)
           (eqt access :internal)
           (handler-case
            (and (unintern sym ph)
                 (multiple-value-bind* (sym2 access2)
                     (find-symbol "FOO" ph)
                   (and (eqt gsym sym2)
                        (eqt access2 :inherited))))
            (error (c) c)))))))
237
  t)
238

239 240 241 242 243 244 245
;;; Specialized sequence tests

(defmacro def-unintern-test (test-name name-form)
  `(deftest ,test-name
     (let ((name ,name-form))
       (safely-delete-package name)
       (prog1
sds's avatar
sds committed
246 247 248 249 250 251 252 253 254 255 256
           (let ((p (make-package name :use nil)))
             (intern "FOO" p)
             (multiple-value-bind*
              (sym access)
              (find-symbol "FOO" p)
              (and
               (eqt access :internal)
               (unintern sym name)
               (null (symbol-package sym))
               (not (find-symbol "FOO" p)))))
         (safely-delete-package name)))
257 258 259 260 261 262 263
     t))

(def-unintern-test unintern.10
  (make-array 5 :initial-contents "TEST1" :element-type 'base-char))

(def-unintern-test unintern.11
  (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
264
              :fill-pointer 5 :element-type 'base-char))
265 266 267

(def-unintern-test unintern.12
  (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
268
              :fill-pointer 5 :element-type 'character))
269 270 271

(def-unintern-test unintern.13
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
272
              :adjustable t :element-type 'base-char))
273 274 275

(def-unintern-test unintern.14
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
276
              :adjustable t :element-type 'character))
277 278 279

(def-unintern-test unintern.15
  (let* ((etype 'base-char)
sds's avatar
sds committed
280 281
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
282
    (make-array 5 :element-type etype
sds's avatar
sds committed
283 284
                :displaced-to name0
                :displaced-index-offset 5)))
285 286 287

(def-unintern-test unintern.16
  (let* ((etype 'character)
sds's avatar
sds committed
288 289
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
290
    (make-array 5 :element-type etype
sds's avatar
sds committed
291 292
                :displaced-to name0
                :displaced-index-offset 5)))
293 294


295
(deftest unintern.error.1
296 297
  (signals-error (unintern) program-error)
  t)
298 299

(deftest unintern.error.2
300 301
  (signals-error (unintern '#:x "CL-TEST" nil) program-error)
  t)