use-package.lsp 11.5 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:08:41 1998
4
;;;; Contains: Tests of USE-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)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; use-package

15
(deftest use-package.1
16
  (progn
17 18
    (safely-delete-package "H")
    (safely-delete-package "G")
19
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
20 21 22
           (ph (make-package "H" :use nil))
           (sym1 (intern "FOO" pg))
           (i 0) x y)
23 24 25 26 27 28
      (and
       (eqt (export sym1 pg) t)
       (null (package-used-by-list pg))
       (null (package-used-by-list ph))
       (null (package-use-list pg))
       (null (package-use-list ph))
29
       (eqt (use-package (progn (setf x (incf i)) pg)
sds's avatar
sds committed
30 31
                         (progn (setf y (incf i)) ph))
            t)  ;; "H" will use "G"
32
       (eql i 2) (eql x 1) (eql y 2)
33
       (multiple-value-bind (sym2 access)
sds's avatar
sds committed
34 35 36 37
           (find-symbol "FOO" ph)
         (and
          (eqt access :inherited)
          (eqt sym1 sym2)))
38 39 40 41 42 43
       (equal (package-use-list ph) (list pg))
       (equal (package-used-by-list pg) (list ph))
       (null (package-use-list pg))
       (null (package-used-by-list ph))
       (eqt (unuse-package pg ph) t)
       (null (find-symbol "FOO" ph)))))
44 45
  t)

46
(deftest use-package.2
47
  (progn
48 49
    (safely-delete-package "H")
    (safely-delete-package "G")
50
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
51 52
           (ph (make-package "H" :use nil))
           (sym1 (intern "FOO" pg)))
53 54 55 56 57 58 59 60
      (and
       (eqt (export sym1 pg) t)
       (null (package-used-by-list pg))
       (null (package-used-by-list ph))
       (null (package-use-list pg))
       (null (package-use-list ph))
       (eqt (use-package "G" "H") t)  ;; "H" will use "G"
       (multiple-value-bind (sym2 access)
sds's avatar
sds committed
61 62 63 64
           (find-symbol "FOO" ph)
         (and
          (eqt access :inherited)
          (eqt sym1 sym2)))
65 66 67 68 69 70
       (equal (package-use-list ph) (list pg))
       (equal (package-used-by-list pg) (list ph))
       (null (package-use-list pg))
       (null (package-used-by-list ph))
       (eqt (unuse-package pg ph) t)
       (null (find-symbol "FOO" ph)))))
71 72
  t)

73
(deftest use-package.3
74
  (progn
75 76
    (safely-delete-package "H")
    (safely-delete-package "G")
77
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
78 79
           (ph (make-package "H" :use nil))
           (sym1 (intern "FOO" pg)))
80 81 82 83 84 85 86 87
      (and
       (eqt (export sym1 pg) t)
       (null (package-used-by-list pg))
       (null (package-used-by-list ph))
       (null (package-use-list pg))
       (null (package-use-list ph))
       (eqt (use-package '#:|G| '#:|H|) t)  ;; "H" will use "G"
       (multiple-value-bind (sym2 access)
sds's avatar
sds committed
88 89 90 91
           (find-symbol "FOO" ph)
         (and
          (eqt access :inherited)
          (eqt sym1 sym2)))
92 93 94 95 96 97
       (equal (package-use-list ph) (list pg))
       (equal (package-used-by-list pg) (list ph))
       (null (package-use-list pg))
       (null (package-used-by-list ph))
       (eqt (unuse-package pg ph) t)
       (null (find-symbol "FOO" ph)))))
98 99
  t)

100
(deftest use-package.4
101
  (progn
102 103
    (safely-delete-package "H")
    (safely-delete-package "G")
104
    (let* ((pg (make-package "G" :use nil))
sds's avatar
sds committed
105 106
           (ph (make-package "H" :use nil))
           (sym1 (intern "FOO" pg)))
107 108 109 110 111 112 113
      (and
       (eqt (export sym1 pg) t)
       (null (package-used-by-list pg))
       (null (package-used-by-list ph))
       (null (package-use-list pg))
       (null (package-use-list ph))
       (eqt (ignore-errors (use-package #\G #\H))
sds's avatar
sds committed
114
            t)  ;; "H" will use "G"
115
       (multiple-value-bind (sym2 access)
sds's avatar
sds committed
116 117 118 119
           (find-symbol "FOO" ph)
         (and
          (eqt access :inherited)
          (eqt sym1 sym2)))
120 121 122 123 124 125
       (equal (package-use-list ph) (list pg))
       (equal (package-used-by-list pg) (list ph))
       (null (package-use-list pg))
       (null (package-used-by-list ph))
       (eqt (unuse-package pg ph) t)
       (null (find-symbol "FOO" ph)))))
126 127 128 129
  t)

;; use lists of packages

130
(deftest use-package.5
131
  (let ((pkgs '("H" "G1" "G2" "G3"))
sds's avatar
sds committed
132
        (vars '("FOO1" "FOO2" "FOO3")))
133
    (dolist (p pkgs)
134
      (safely-delete-package p)
135 136 137 138 139
      (make-package p :use nil))
    (and
     (every (complement #'package-use-list) pkgs)
     (every (complement #'package-used-by-list) pkgs)
     (every #'(lambda (v p)
sds's avatar
sds committed
140 141
                (export (intern v p) p))
            vars (cdr pkgs))
142 143 144 145
     (progn
       (dolist (p (cdr pkgs)) (intern "MINE" p))
       (eqt (use-package (cdr pkgs) (car pkgs)) t))
     (every #'(lambda (v p)
sds's avatar
sds committed
146 147 148
                (eqt (find-symbol v p)
                     (find-symbol v (car pkgs))))
            vars (cdr pkgs))
149 150
     (null (find-symbol "MINE" (car pkgs)))
     (every #'(lambda (p)
sds's avatar
sds committed
151 152 153
                (equal (package-used-by-list p)
                       (list (find-package (car pkgs)))))
            (cdr pkgs))
154
     (equal (sort-package-list (package-use-list (car pkgs)))
sds's avatar
sds committed
155
            (mapcar #'find-package (cdr pkgs)))
156 157
     (every (complement #'package-use-list) (cdr pkgs))
     (null (package-used-by-list (car pkgs)))))
158 159 160 161
  t)

;; Circular package use

162
(deftest use-package.6
163
  (progn
164 165
    (safely-delete-package "H")
    (safely-delete-package "G")
166
    (let ((pg (make-package "G"))
sds's avatar
sds committed
167 168 169
          (ph (make-package "H"))
          sym1 sym2 sym3 sym4
          a1 a2 a3 a4)
170
      (prog1
sds's avatar
sds committed
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
          (and
           (export (intern "X" pg) pg)
           (export (intern "Y" ph) ph)
           (use-package pg ph)
           (use-package ph pg)
           (progn
             (multiple-value-setq
                 (sym1 a1) (find-symbol "X" pg))
             (multiple-value-setq
                 (sym2 a2) (find-symbol "Y" ph))
             (multiple-value-setq
                 (sym3 a3) (find-symbol "Y" pg))
             (multiple-value-setq
                 (sym4 a4) (find-symbol "X" ph))
             (and
              (eqt a1 :external)
              (eqt a2 :external)
              (eqt a3 :inherited)
              (eqt a4 :inherited)
              (eqt sym1 sym4)
              (eqt sym2 sym3)
              (eqt (symbol-package sym1) pg)
              (eqt (symbol-package sym2) ph)
              (unuse-package pg ph)
              (unuse-package ph pg))))
        (safely-delete-package pg)
        (safely-delete-package ph))))
198 199
  t)

200 201 202 203
;; Check that *PACKAGE* is used as a default

(deftest use-package.7
  (let ((user-name "H")
sds's avatar
sds committed
204
        (used-name "G"))
205 206 207
    (safely-delete-package user-name)
    (safely-delete-package used-name)
    (let* ((pused (make-package used-name :use nil))
sds's avatar
sds committed
208 209
           (puser (make-package user-name :use nil))
           (sym1 (intern "FOO" pused)))
210 211 212 213 214 215 216 217
      (and
       (eqt (export sym1 pused) t)
       (null (package-used-by-list pused))
       (null (package-used-by-list puser))
       (null (package-use-list pused))
       (null (package-use-list puser))
       (eqt (let ((*package* puser)) (use-package pused)) t)  ;; user will use used
       (multiple-value-bind (sym2 access)
sds's avatar
sds committed
218 219 220 221
           (find-symbol "FOO" puser)
         (and
          (eqt access :inherited)
          (eqt sym1 sym2)))
222 223 224 225 226 227 228 229 230 231 232 233 234
       (equal (package-use-list puser) (list pused))
       (equal (package-used-by-list pused) (list puser))
       (null (package-use-list pused))
       (null (package-used-by-list puser))
       (eqt (unuse-package pused puser) t)
       (null (find-symbol "FOO" puser)))))
  t)

;;; Tests for specialized sequence arguments

(defmacro def-use-package-test (test-name &key (user "H") (used "G"))
  `(deftest ,test-name
     (let ((user-name ,user)
sds's avatar
sds committed
235
           (used-name ,used))
236 237 238
       (safely-delete-package user-name)
       (safely-delete-package used-name)
       (let* ((pused (make-package used-name :use nil))
sds's avatar
sds committed
239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258
              (puser (make-package user-name :use nil))
              (sym1 (intern "FOO" pused)))
         (and
          (eqt (export sym1 pused) t)
          (null (package-used-by-list pused))
          (null (package-used-by-list puser))
          (null (package-use-list pused))
          (null (package-use-list puser))
          (eqt (let ((*package* puser)) (use-package pused)) t)  ;; user will use used
          (multiple-value-bind (sym2 access)
              (find-symbol "FOO" puser)
            (and
             (eqt access :inherited)
             (eqt sym1 sym2)))
          (equal (package-use-list puser) (list pused))
          (equal (package-used-by-list pused) (list puser))
          (null (package-use-list pused))
          (null (package-used-by-list puser))
          (eqt (unuse-package pused puser) t)
          (null (find-symbol "FOO" puser)))))
259 260 261 262 263 264 265 266 267
     t))

;;; Specialized user package designator

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

(def-use-package-test use-package.11
  :user (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
268
                    :fill-pointer 5 :element-type 'base-char))
269 270 271

(def-use-package-test use-package.12
  :user (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
272
                    :fill-pointer 5 :element-type 'character))
273 274 275

(def-use-package-test use-package.13
  :user (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
276
                    :adjustable t :element-type 'base-char))
277 278 279

(def-use-package-test use-package.14
  :user (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
280
                    :adjustable t :element-type 'character))
281 282 283

(def-use-package-test use-package.15
  :user (let* ((etype 'base-char)
sds's avatar
sds committed
284 285 286 287 288
               (name0 (make-array 10 :element-type etype
                                  :initial-contents "xxxxxTEST1")))
          (make-array 5 :element-type etype
                      :displaced-to name0
                      :displaced-index-offset 5)))
289 290 291 292

(def-use-package-test use-package.16
  :user
  (let* ((etype 'character)
sds's avatar
sds committed
293 294
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
295
    (make-array 5 :element-type etype
sds's avatar
sds committed
296 297
                :displaced-to name0
                :displaced-index-offset 5)))
298 299 300 301 302 303 304 305

;;; Specialed used package designator

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

(def-use-package-test use-package.18
  :used (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
306
                    :fill-pointer 5 :element-type 'base-char))
307 308 309

(def-use-package-test use-package.19
  :used (make-array 10 :initial-contents "TEST1ABCDE"
sds's avatar
sds committed
310
                    :fill-pointer 5 :element-type 'character))
311 312 313

(def-use-package-test use-package.20
  :used (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
314
                    :adjustable t :element-type 'base-char))
315 316 317

(def-use-package-test use-package.21
  :used (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
318
                    :adjustable t :element-type 'character))
319 320 321

(def-use-package-test use-package.22
  :used (let* ((etype 'base-char)
sds's avatar
sds committed
322 323 324 325 326
               (name0 (make-array 10 :element-type etype
                                  :initial-contents "xxxxxTEST1")))
          (make-array 5 :element-type etype
                      :displaced-to name0
                      :displaced-index-offset 5)))
327 328 329 330

(def-use-package-test use-package.23
  :used
  (let* ((etype 'character)
sds's avatar
sds committed
331 332
         (name0 (make-array 10 :element-type etype
                            :initial-contents "xxxxxTEST1")))
333
    (make-array 5 :element-type etype
sds's avatar
sds committed
334 335
                :displaced-to name0
                :displaced-index-offset 5)))
336 337

(deftest use-package.error.1
338 339
  (signals-error (use-package) program-error)
  t)
340 341 342

(deftest use-package.error.2
  (progn
343 344
    (safely-delete-package "UPE2A")
    (safely-delete-package "UPE2")
345 346
    (make-package "UPE2" :use ())
    (make-package "UPE2A" :use ())
347 348
    (signals-error (use-package "UPE2" "UPE2A" nil) program-error))
  t)