unexport.lsp 5.63 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:04:19 1998
4
;;;; Contains: Tests of UNEXPORT
5 6 7 8 9 10 11

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; unexport

12 13 14 15
(deftest unexport.1
  (progn
    (safely-delete-package "X")
    (let* ((p (make-package "X" :use nil))
sds's avatar
sds committed
16 17
           (r (export (intern "X" p) p))
           (i 0) x y)
18 19 20 21
      (multiple-value-bind*
       (sym1 access1)
       (find-symbol "X" p)
       (unexport (progn (setf x (incf i)) sym1)
sds's avatar
sds committed
22
                 (progn (setf y (incf i)) p))
23
       (multiple-value-bind*
sds's avatar
sds committed
24 25 26 27 28 29 30 31 32
        (sym2 access2)
        (find-symbol "X" p)
        (and (eqt r t)
             (eql i 2) (eql x 1) (eql y 2)
             (eqt sym1 sym2)
             (eqt access1 :external)
             (eqt access2 :internal)
             (equal (symbol-name sym1) "X")
             t)))))
33
  t)
sds's avatar
sds committed
34

35 36 37 38
(deftest unexport.2
  (progn
    (safely-delete-package "X")
    (let* ((p (make-package "X" :use nil))
sds's avatar
sds committed
39
           (r (export (intern "X" p) p)))
40 41 42 43 44
      (multiple-value-bind*
       (sym1 access1)
       (find-symbol "X" p)
       (unexport (list sym1) "X")
       (multiple-value-bind*
sds's avatar
sds committed
45 46 47 48 49 50 51 52
        (sym2 access2)
        (find-symbol "X" p)
        (and (eqt sym1 sym2)
             (eqt r t)
             (eqt access1 :external)
             (eqt access2 :internal)
             (equal (symbol-name sym1) "X")
             t)))))
53 54
  t)

55 56 57 58
(deftest unexport.3
  (progn
    (safely-delete-package "X")
    (let* ((p (make-package "X" :use nil))
sds's avatar
sds committed
59 60
           (r1 (export (intern "X" p) p))
           (r2 (export (intern "Y" p) p)))
61 62 63 64
      (multiple-value-bind*
       (sym1 access1)
       (find-symbol "X" p)
       (multiple-value-bind*
sds's avatar
sds committed
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
        (sym1a access1a)
        (find-symbol "Y" p)
        (unexport (list sym1 sym1a) '#:|X|)
        (multiple-value-bind*
         (sym2 access2)
         (find-symbol "X" p)
         (multiple-value-bind*
          (sym2a access2a)
          (find-symbol "Y" p)
          (and (eqt sym1 sym2)
               (eqt sym1a sym2a)
               (eqt r1 t)
               (eqt r2 t)
               (eqt access1 :external)
               (eqt access2 :internal)
               (eqt access1a :external)
               (eqt access2a :internal)
               (equal (symbol-name sym1) "X")
               (equal (symbol-name sym1a) "Y")
               t)))))))
85 86
  t)

87 88 89 90
(deftest unexport.4
  (progn
    (safely-delete-package "X")
    (let* ((p (make-package "X" :use nil))
sds's avatar
sds committed
91
           (r (export (intern "X" p) p)))
92 93 94 95 96
      (multiple-value-bind*
       (sym1 access1)
       (find-symbol "X" p)
       (unexport (list sym1) #\X)
       (multiple-value-bind*
sds's avatar
sds committed
97 98 99 100 101 102 103 104
        (sym2 access2)
        (find-symbol "X" p)
        (and (eqt sym1 sym2)
             (eqt r t)
             (eqt access1 :external)
             (eqt access2 :internal)
             (equal (symbol-name sym1) "X")
             t)))))
105 106 107 108 109
  t)

;; Check that it signals a package error when unexporting
;;  an inaccessible symbol

110
(deftest unexport.5
111
  (signals-error
112 113 114
   (progn
     (when (find-package "X") (delete-package "X"))
     (unexport 'a (make-package "X" :use nil))
115 116 117
     nil)
   package-error)
  t)
118 119 120

;; Check that internal symbols are left alone

121 122 123 124 125
(deftest unexport.6
  (progn
    (when (find-package "X") (delete-package "X"))
    (let ((p (make-package "X" :use nil)))
      (let* ((sym (intern "FOO" p))
sds's avatar
sds committed
126 127 128 129 130 131 132 133 134
             (r (unexport sym p)))
        (multiple-value-bind*
         (sym2 access)
         (find-symbol "FOO" p)
         (and (eqt r t)
              (eqt access :internal)
              (eqt sym sym2)
              (equal (symbol-name sym) "FOO")
              t)))))
135
  t)
136

137 138 139 140 141 142 143
;;; Specialized sequence tests

(defmacro def-unexport-test (test-name name-form)
  `(deftest ,test-name
     (let ((name ,name-form))
       (safely-delete-package name)
       (let* ((p (make-package name :use nil))
sds's avatar
sds committed
144 145 146 147 148 149 150 151 152 153 154 155 156 157
              (r (export (intern "X" p) p)))
         (multiple-value-bind*
          (sym1 access1)
          (find-symbol "X" p)
          (unexport (list sym1) name)
          (multiple-value-bind*
           (sym2 access2)
           (find-symbol "X" p)
           (and (eqt sym1 sym2)
                (eqt r t)
                (eqt access1 :external)
                (eqt access2 :internal)
                (equal (symbol-name sym1) "X")
                t)))))
158 159 160 161 162 163 164
     t))

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

(def-unexport-test unexport.8
  (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
165
              :fill-pointer 5 :element-type 'base-char))
166 167 168

(def-unexport-test unexport.9
  (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
169
              :fill-pointer 5 :element-type 'character))
170 171 172

(def-unexport-test unexport.10
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
173
              :adjustable t :element-type 'base-char))
174 175 176

(def-unexport-test unexport.11
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
177
              :adjustable t :element-type 'character))
178 179 180

(def-unexport-test unexport.12
  (let* ((etype 'base-char)
sds's avatar
sds committed
181 182
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
183
    (make-array 5 :element-type etype
sds's avatar
sds committed
184 185
                :displaced-to name0
                :displaced-index-offset 5)))
186 187 188

(def-unexport-test unexport.13
  (let* ((etype 'character)
sds's avatar
sds committed
189 190
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
191
    (make-array 5 :element-type etype
sds's avatar
sds committed
192 193
                :displaced-to name0
                :displaced-index-offset 5)))
194 195 196

;;; Error tests

197
(deftest unexport.error.1
198 199
  (signals-error (unexport) program-error)
  t)
200 201

(deftest unexport.error.2
202 203
  (signals-error (unexport 'xyz "CL-TEST" nil) program-error)
  t)