unuse-package.lsp 10.2 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:06:48 1998
4
;;;; Contains: Tests of UNUSE-PACKAGE
5 6

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

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

10 11 12 13 14
(declaim (optimize (safety 3)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; unuse-package

15
(deftest unuse-package.1
16 17 18 19
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
20 21
           (ph (make-package "H" :use '("G")))
           (i 0) x y)
22
      (prog1
sds's avatar
sds committed
23 24 25 26 27 28 29 30 31 32
          (and
           (equal (package-use-list ph) (list pg))
           (equal (package-used-by-list pg) (list ph))
           (unuse-package (progn (setf x (incf i)) pg)
                          (progn (setf y (incf i)) ph))
           (eql i 2) (eql x 1) (eql y 2)
           (equal (package-use-list ph) nil)
           (null (package-used-by-list pg)))
        (safely-delete-package "H")
        (safely-delete-package "G"))))
33 34
  t)

35
(deftest unuse-package.2
36 37 38 39
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
40
           (ph (make-package "H" :use '("G"))))
41
      (prog1
sds's avatar
sds committed
42 43 44 45 46 47 48 49 50
          (and
           (equal (package-use-list ph) (list pg))
           (equal (package-used-by-list pg) (list ph))
           (unuse-package "G" ph)
           (equal (package-use-list ph) nil)
           (null (package-used-by-list pg)))
        (safely-delete-package "H")
        (safely-delete-package "G"))))
  t)
51

52
(deftest unuse-package.3
53 54 55 56
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
57
           (ph (make-package "H" :use '("G"))))
58
      (prog1
sds's avatar
sds committed
59 60 61 62 63 64 65 66
          (and
           (equal (package-use-list ph) (list pg))
           (equal (package-used-by-list pg) (list ph))
           (unuse-package :|G| ph)
           (equal (package-use-list ph) nil)
           (null (package-used-by-list pg)))
        (safely-delete-package "H")
        (safely-delete-package "G"))))
67 68
  t)

69
(deftest unuse-package.4
70 71 72 73
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
74
           (ph (make-package "H" :use '("G"))))
75
      (prog1
sds's avatar
sds committed
76 77 78 79 80 81 82 83
          (and
           (equal (package-use-list ph) (list pg))
           (equal (package-used-by-list pg) (list ph))
           (ignore-errors (unuse-package #\G ph))
           (equal (package-use-list ph) nil)
           (null (package-used-by-list pg)))
        (safely-delete-package "H")
        (safely-delete-package "G"))))
84 85
  t)

86
(deftest unuse-package.5
87 88 89 90
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
91
           (ph (make-package "H" :use '("G"))))
92
      (prog1
sds's avatar
sds committed
93 94 95 96 97 98 99 100 101
          (and
           (equal (package-use-list ph) (list pg))
           (equal (package-used-by-list pg) (list ph))
           (unuse-package (list pg) ph)
           (equal (package-use-list ph) nil)
           (null (package-used-by-list pg)))
        (safely-delete-package "H")
        (safely-delete-package "G"))))
  t)
102

103
(deftest unuse-package.6
104 105 106 107
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
108
           (ph (make-package "H" :use '("G"))))
109
      (prog1
sds's avatar
sds committed
110 111 112 113 114 115 116 117
          (and
           (equal (package-use-list ph) (list pg))
           (equal (package-used-by-list pg) (list ph))
           (unuse-package (list "G") ph)
           (equal (package-use-list ph) nil)
           (null (package-used-by-list pg)))
        (safely-delete-package "H")
        (safely-delete-package "G"))))
118 119
  t)

120
(deftest unuse-package.7
121 122 123 124
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
125
           (ph (make-package "H" :use '("G"))))
126
      (prog1
sds's avatar
sds committed
127 128 129 130 131 132 133 134
          (and
           (equal (package-use-list ph) (list pg))
           (equal (package-used-by-list pg) (list ph))
           (unuse-package (list :|G|) ph)
           (equal (package-use-list ph) nil)
           (null (package-used-by-list pg)))
        (safely-delete-package "H")
        (safely-delete-package "G"))))
135 136
  t)

137
(deftest unuse-package.8
138 139 140 141
  (progn
    (safely-delete-package "H")
    (safely-delete-package "G")
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
142
           (ph (make-package "H" :use '("G"))))
143
      (prog1
sds's avatar
sds committed
144 145 146 147 148 149 150 151
          (and
           (equal (package-use-list ph) (list pg))
           (equal (package-used-by-list pg) (list ph))
           (ignore-errors (unuse-package (list #\G) ph))
           (equal (package-use-list ph) nil)
           (null (package-used-by-list pg)))
        (safely-delete-package "H")
        (safely-delete-package "G"))))
152 153 154 155
  t)

;; Now test with multiple packages

156
(deftest unuse-package.9
157 158 159 160
  (progn
    (dolist (p '("H1" "H2" "G1" "G2" "G3"))
      (safely-delete-package p))
    (let* ((pg1 (make-package "G1" :use nil))
sds's avatar
sds committed
161 162 163 164
           (pg2 (make-package "G2" :use nil))
           (pg3 (make-package "G3" :use nil))
           (ph1 (make-package "H1" :use (list pg1 pg2 pg3)))
           (ph2 (make-package "H2" :use (list pg1 pg2 pg3))))
165
      (let ((pubg1 (sort-package-list (package-used-by-list pg1)))
sds's avatar
sds committed
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
            (pubg2 (sort-package-list (package-used-by-list pg2)))
            (pubg3 (sort-package-list (package-used-by-list pg3)))
            (puh1  (sort-package-list (package-use-list ph1)))
            (puh2  (sort-package-list (package-use-list ph2))))
        (prog1
            (and
             (= (length (remove-duplicates (list pg1 pg2 pg3 ph1 ph2)))
                5)
             (equal (list ph1 ph2) pubg1)
             (equal (list ph1 ph2) pubg2)
             (equal (list ph1 ph2) pubg3)
             (equal (list pg1 pg2 pg3) puh1)
             (equal (list pg1 pg2 pg3) puh2)
             (unuse-package (list pg1 pg3) ph1)
             (equal (package-use-list ph1) (list pg2))
             (equal (package-used-by-list pg1) (list ph2))
             (equal (package-used-by-list pg3) (list ph2))
             (equal (sort-package-list (package-use-list ph2))
                    (list pg1 pg2 pg3))
             (equal (sort-package-list (package-used-by-list pg2))
                    (list ph1 ph2))
             t)
          (dolist (p '("H1" "H2" "G1" "G2" "G3"))
            (safely-delete-package p))))))
190
  t)
191

192 193 194
;;; Specialized sequences

(defmacro def-unuse-package-test (test-name &key
sds's avatar
sds committed
195 196
                                            (user "H")
                                            (used "G"))
197 198
  `(deftest ,test-name
     (let ((user-name ,user)
sds's avatar
sds committed
199
           (used-name ,used))
200 201 202
       (safely-delete-package user-name)
       (safely-delete-package used-name)
       (let* ((pused (make-package used-name :use nil))
sds's avatar
sds committed
203 204 205 206 207 208 209 210 211 212
              (puser (make-package user-name :use (list used-name))))
         (prog1
             (and
              (equal (package-use-list puser) (list pused))
              (equal (package-used-by-list pused) (list puser))
              (unuse-package (list used-name) user-name)
              (equal (package-use-list puser) nil)
              (null (package-used-by-list pused)))
           (safely-delete-package user-name)
           (safely-delete-package used-name))))
213 214 215 216 217 218 219 220 221
     t))

;;; Specialized user package designator

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

(def-unuse-package-test unuse-package.11
  :user (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
222
                    :fill-pointer 5 :element-type 'base-char))
223 224 225

(def-unuse-package-test unuse-package.12
  :user (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
226
                    :fill-pointer 5 :element-type 'character))
227 228 229

(def-unuse-package-test unuse-package.13
  :user (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
230
                    :adjustable t :element-type 'base-char))
231 232 233

(def-unuse-package-test unuse-package.14
  :user (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
234
                    :adjustable t :element-type 'character))
235 236 237

(def-unuse-package-test unuse-package.15
  :user (let* ((etype 'base-char)
sds's avatar
sds committed
238 239 240 241 242
               (name0 (make-array 10 :element-type etype
                                  :initial-contents "xxxxxTEST1")))
          (make-array 5 :element-type etype
                      :displaced-to name0
                      :displaced-index-offset 5)))
243 244 245 246

(def-unuse-package-test unuse-package.16
  :user
  (let* ((etype 'character)
sds's avatar
sds committed
247 248
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
249
    (make-array 5 :element-type etype
sds's avatar
sds committed
250 251
                :displaced-to name0
                :displaced-index-offset 5)))
252 253 254 255 256 257 258 259

;;; Specialed used package designator

(def-unuse-package-test unuse-package.17
  :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char))

(def-unuse-package-test unuse-package.18
  :used (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
260
                    :fill-pointer 5 :element-type 'base-char))
261 262 263

(def-unuse-package-test unuse-package.19
  :used (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
264
                    :fill-pointer 5 :element-type 'character))
265 266 267

(def-unuse-package-test unuse-package.20
  :used (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
268
                    :adjustable t :element-type 'base-char))
269 270 271

(def-unuse-package-test unuse-package.21
  :used (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
272
                    :adjustable t :element-type 'character))
273 274 275

(def-unuse-package-test unuse-package.22
  :used (let* ((etype 'base-char)
sds's avatar
sds committed
276 277 278 279 280
               (name0 (make-array 10 :element-type etype
                                  :initial-contents "xxxxxTEST1")))
          (make-array 5 :element-type etype
                      :displaced-to name0
                      :displaced-index-offset 5)))
281 282 283 284

(def-unuse-package-test unuse-package.23
  :used
  (let* ((etype 'character)
sds's avatar
sds committed
285 286
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
287
    (make-array 5 :element-type etype
sds's avatar
sds committed
288 289
                :displaced-to name0
                :displaced-index-offset 5)))
290 291 292

;;; Error tests

293
(deftest unuse-package.error.1
294 295
  (signals-error (unuse-package) program-error)
  t)
296 297 298

(deftest unuse-package.error.2
  (progn
299 300
    (safely-delete-package "UPE2A")
    (safely-delete-package "UPE2")
301 302
    (make-package "UPE2" :use ())
    (make-package "UPE2A" :use '("UPE2"))
303 304
    (signals-error (unuse-package "UPE2" "UPE2A" nil) program-error))
  t)