make-package.lsp 16.3 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:02:43 1998
4
;;;; Contains: Tests of MAKE-PACKAGE
5

6

7 8 9 10 11 12 13 14
(declaim (optimize (safety 3)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; make-package

;; Test basic make-package, using string, symbol and character
;;    package-designators

15
(deftest make-package.1
16 17 18 19
  (progn
    (safely-delete-package "TEST1")
    (let ((p (ignore-errors (make-package "TEST1"))))
      (prog1
sds's avatar
sds committed
20 21 22 23 24
          (and (packagep p)
               (equalt (package-name p) "TEST1")
               (equalt (package-nicknames p) nil)
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
25 26
  t)

27
(deftest make-package.2
28 29 30 31
  (progn
    (safely-delete-package '#:|TEST1|)
    (let ((p (ignore-errors (make-package '#:|TEST1|))))
      (prog1
sds's avatar
sds committed
32 33 34 35 36
          (and (packagep p)
               (equalt (package-name p) "TEST1")
               (equalt (package-nicknames p) nil)
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
37 38
  t)

39
(deftest make-package.3
40 41 42 43
  (progn
    (safely-delete-package #\X)
    (let ((p (ignore-errors (make-package #\X))))
      (prog1
sds's avatar
sds committed
44 45 46 47 48
          (and (packagep p)
               (equalt (package-name p) "X")
               (equalt (package-nicknames p) nil)
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
49
  t)
50

51 52
;; Same, but with a null :use list

53
(deftest make-package.4
54 55 56 57
  (progn
    (safely-delete-package "TEST1")
    (let ((p (ignore-errors (make-package "TEST1" :use nil))))
      (prog1
sds's avatar
sds committed
58 59 60 61 62 63
          (and (packagep p)
               (equalt (package-name p) "TEST1")
               (equalt (package-nicknames p) nil)
               (equalt (package-use-list p) nil)
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
64 65
  t)

66
(deftest make-package.5
67 68 69 70
  (progn
    (safely-delete-package '#:|TEST1|)
    (let ((p (ignore-errors (make-package '#:|TEST1| :use nil))))
      (prog1
sds's avatar
sds committed
71 72 73 74 75 76
          (and (packagep p)
               (equalt (package-name p) "TEST1")
               (equalt (package-nicknames p) nil)
               (equalt (package-use-list p) nil)
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
77 78
  t)

79
(deftest make-package.6
80 81 82 83
  (progn
    (safely-delete-package #\X)
    (let ((p (make-package #\X)))
      (prog1
sds's avatar
sds committed
84 85 86 87 88 89
          (and (packagep p)
               (equalt (package-name p) "X")
               (equalt (package-nicknames p) nil)
               ;; (equalt (package-use-list p) nil)
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
90 91 92 93
  t)

;; Same, but use the A package

94
(deftest make-package.7
95
  (progn
96
    (set-up-packages)
97 98 99
    (safely-delete-package "TEST1")
    (let ((p (ignore-errors (make-package "TEST1" :use '("A")))))
      (prog1
sds's avatar
sds committed
100 101 102 103 104 105
          (and (packagep p)
               (equalt (package-name p) "TEST1")
               (equalt (package-nicknames p) nil)
               (equalt (package-use-list p) (list (find-package "A")))
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
106 107
  t)

108
(deftest make-package.7a
109
  (progn
110
    (set-up-packages)
111 112 113
    (safely-delete-package "TEST1")
    (let ((p (ignore-errors (make-package "TEST1" :use '(#:|A|)))))
      (prog1
sds's avatar
sds committed
114 115 116 117 118 119
          (and (packagep p)
               (equalt (package-name p) "TEST1")
               (equalt (package-nicknames p) nil)
               (equalt (package-use-list p) (list (find-package "A")))
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
120 121
  t)

122
(deftest make-package.7b
123
  (progn
124
    (set-up-packages)
125 126 127
    (safely-delete-package "TEST1")
    (let ((p (ignore-errors (make-package "TEST1" :use '(#\A)))))
      (prog1
sds's avatar
sds committed
128 129 130 131 132 133
          (and (packagep p)
               (equalt (package-name p) "TEST1")
               (equalt (package-nicknames p) nil)
               (equalt (package-use-list p) (list (find-package "A")))
               (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
134 135
  t)

136
(deftest make-package.8
137
  (progn
138
    (set-up-packages)
139 140
    (safely-delete-package '#:|TEST1|)
    (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A")))))
141
      (multiple-value-prog1
sds's avatar
sds committed
142 143 144 145 146 147
          (values (notnot (packagep p))
                  (equalt (package-name p) "TEST1")
                  (equalt (package-nicknames p) nil)
                  (equalt (package-use-list p) (list (find-package "A")))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
148
  t t t t t)
149

150
(deftest make-package.8a
151
  (progn
152
    (set-up-packages)
153 154
    (safely-delete-package '#:|TEST1|)
    (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|)))))
155
      (multiple-value-prog1
sds's avatar
sds committed
156 157 158 159 160 161
          (values (notnot (packagep p))
                  (equalt (package-name p) "TEST1")
                  (equalt (package-nicknames p) nil)
                  (equalt (package-use-list p) (list (find-package "A")))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
162
  t t t t t)
163

164
(deftest make-package.8b
165
  (progn
166
    (set-up-packages)
167 168
    (safely-delete-package '#:|TEST1|)
    (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A)))))
169
      (multiple-value-prog1
sds's avatar
sds committed
170 171 172 173 174 175
          (values (packagep p)
                  (equalt (package-name p) "TEST1")
                  (equalt (package-nicknames p) nil)
                  (equalt (package-use-list p) (list (find-package "A")))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
176
  t t t t t)
177

178
(deftest make-package.9
179
  (progn
180
    (set-up-packages)
181 182
    (safely-delete-package #\X)
    (let ((p (ignore-errors (make-package #\X :use '("A")))))
183
      (multiple-value-prog1
sds's avatar
sds committed
184 185 186 187 188 189
          (values (notnot (packagep p))
                  (equalt (package-name p) "X")
                  (equalt (package-nicknames p) nil)
                  (equalt (package-use-list p) (list (find-package "A")))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
190
  t t t t t)
191

192
(deftest make-package.9a
193
  (progn
194
    (set-up-packages)
195 196
    (safely-delete-package #\X)
    (let ((p (ignore-errors (make-package #\X :use '(#:|A|)))))
197
      (multiple-value-prog1
sds's avatar
sds committed
198 199 200 201 202 203
          (values (notnot (packagep p))
                  (equalt (package-name p) "X")
                  (equalt (package-nicknames p) nil)
                  (equalt (package-use-list p) (list (find-package "A")))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
204
  t t t t t)
205

206
(deftest make-package.9b
207
  (progn
208
    (set-up-packages)
209 210
    (safely-delete-package #\X)
    (let ((p (ignore-errors (make-package #\X :use '(#\A)))))
211
      (multiple-value-prog1
sds's avatar
sds committed
212 213 214 215 216 217
          (values (notnot (packagep p))
                  (equalt (package-name p) "X")
                  (equalt (package-nicknames p) nil)
                  (equalt (package-use-list p) (list (find-package "A")))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
218
  t t t t t)
219 220 221

;; make-package with nicknames

222
(deftest make-package.10
223
  (progn
224
    (mapc #'safely-delete-package '("TEST1" "F"))
225
    (let ((p (make-package "TEST1" :nicknames '("F"))))
226
      (multiple-value-prog1
sds's avatar
sds committed
227 228 229 230 231
          (values (notnot (packagep p))
                  (equalt (package-name p) "TEST1")
                  (equalt (package-nicknames p) '("F"))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
232
  t t t t)
233

234
(deftest make-package.11
235
  (progn
236
    (mapc #'safely-delete-package '("TEST1" "G"))
237
    (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|))))
238
      (multiple-value-prog1
sds's avatar
sds committed
239 240 241 242 243
          (values (notnot (packagep p))
                  (equalt (package-name p) "TEST1")
                  (equalt (package-nicknames p) '("G"))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
244
  t t t t)
245

246
(deftest make-package.12
247
  (progn
248
    (mapc #'safely-delete-package '("TEST1" "G"))
249
    (let ((p (make-package '#:|TEST1| :nicknames '(#\G))))
250
      (multiple-value-prog1
sds's avatar
sds committed
251 252 253 254 255
          (values (notnot (packagep p))
                  (equalt (package-name p) "TEST1")
                  (equalt (package-nicknames p) '("G"))
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
256
  t t t t)
257

258
(deftest make-package.13
259
  (progn
260
    (mapc #'safely-delete-package '(#\X #\F #\G #\H))
261
    (let ((p (make-package #\X :nicknames '("F" #\G #:|H|))))
262
      (multiple-value-prog1
sds's avatar
sds committed
263 264 265 266 267 268 269
          (values (notnot (packagep p))
                  (equalt (package-name p) "X")
                  (set-exclusive-or (package-nicknames p)
                                    '("F" "G" "H")
                                    :test #'equal)
                  (equalt (package-used-by-list p) nil))
        (safely-delete-package p))))
270
  t t nil t)
271

272 273 274 275 276 277 278 279 280 281
;;; Specialized sequences as designators

;;; The package name being a specialized sequence

(defmacro def-make-package-test1 (test-name name-form)
  `(deftest ,test-name
     (let ((name ,name-form))
       (assert (string= name "TEST1"))
       (safely-delete-package "TEST1")
       (let ((p (ignore-errors (make-package name))))
sds's avatar
sds committed
282 283 284 285 286 287
         (multiple-value-prog1
          (values (notnot (packagep p))
                  (equalt (package-name p) "TEST1")
                  (equalt (package-nicknames p) nil)
                  (equalt (package-used-by-list p) nil))
          (safely-delete-package p))))
288
     t t t t))
289 290 291

(def-make-package-test1 make-package.14
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
292
              :element-type 'base-char))
293 294 295

(def-make-package-test1 make-package.15
  (make-array 12 :initial-contents "TEST1xxxyyyz"
sds's avatar
sds committed
296 297
              :fill-pointer 5
              :element-type 'base-char))
298 299 300

(def-make-package-test1 make-package.16
  (make-array 12 :initial-contents "TEST1xxxyyyz"
sds's avatar
sds committed
301 302
              :fill-pointer 5
              :element-type 'character))
303 304 305

(def-make-package-test1 make-package.17
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
306 307
              :adjustable t
              :element-type 'base-char))
308 309 310

(def-make-package-test1 make-package.18
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
311 312
              :adjustable t
              :element-type 'character))
313 314 315

(def-make-package-test1 make-package.19
  (let* ((etype 'base-char)
sds's avatar
sds committed
316 317
         (name0 (make-array 10 :initial-contents "xxTEST1yyy"
                            :element-type etype)))
318
    (make-array 5 :element-type etype
sds's avatar
sds committed
319 320
                :displaced-to name0
                :displaced-index-offset 2)))
321 322 323

(def-make-package-test1 make-package.20
  (let* ((etype 'character)
sds's avatar
sds committed
324 325
         (name0 (make-array 10 :initial-contents "xxTEST1yyy"
                            :element-type etype)))
326
    (make-array 5 :element-type etype
sds's avatar
sds committed
327 328
                :displaced-to name0
                :displaced-index-offset 2)))
329 330 331 332 333 334

;;; Nicknames being specialized sequences

(defmacro def-make-package-test2 (test-name name-form)
  `(deftest ,test-name
     (let ((name ,name-form)
sds's avatar
sds committed
335
           (nickname "TEST1-NICKNAME"))
336 337 338
       (safely-delete-package "TEST1")
       (safely-delete-package nickname)
       (let ((p (make-package name :nicknames (list nickname))))
sds's avatar
sds committed
339 340 341 342 343 344
         (multiple-value-prog1
             (values (notnot (packagep p))
                     (equalt (package-name p) "TEST1")
                     (equalt (package-nicknames p) (list nickname))
                     (equalt (package-used-by-list p) nil))
             (safely-delete-package p))))
345
     t t t t))
346 347 348

(def-make-package-test2 make-package.21
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
349
              :element-type 'base-char))
350 351 352

(def-make-package-test2 make-package.22
  (make-array 12 :initial-contents "TEST1xxxyyyz"
sds's avatar
sds committed
353 354
              :fill-pointer 5
              :element-type 'base-char))
355 356 357

(def-make-package-test2 make-package.23
  (make-array 12 :initial-contents "TEST1xxxyyyz"
sds's avatar
sds committed
358 359
              :fill-pointer 5
              :element-type 'character))
360 361 362

(def-make-package-test2 make-package.24
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
363 364
              :adjustable t
              :element-type 'base-char))
365 366 367

(def-make-package-test2 make-package.25
  (make-array 5 :initial-contents "TEST1"
sds's avatar
sds committed
368 369
              :adjustable t
              :element-type 'character))
370 371 372

(def-make-package-test2 make-package.26
  (let* ((etype 'base-char)
sds's avatar
sds committed
373 374
         (name0 (make-array 10 :initial-contents "xxTEST1yyy"
                            :element-type etype)))
375
    (make-array 5 :element-type etype
sds's avatar
sds committed
376 377
                :displaced-to name0
                :displaced-index-offset 2)))
378 379 380

(def-make-package-test2 make-package.27
  (let* ((etype 'character)
sds's avatar
sds committed
381 382
         (name0 (make-array 10 :initial-contents "xxTEST1yyy"
                            :element-type etype)))
383
    (make-array 5 :element-type etype
sds's avatar
sds committed
384 385
                :displaced-to name0
                :displaced-index-offset 2)))
386 387 388 389 390 391

;;; USE names being specialized sequences

(defmacro def-make-package-test3 (test-name name-form)
  `(deftest ,test-name
     (let ((name ,name-form))
392
       (set-up-packages)
393 394 395
       (safely-delete-package "TEST1")
       (assert (find-package name))
       (let ((p (ignore-errors (make-package "TEST1" :use (list name)))))
sds's avatar
sds committed
396 397 398 399 400 401 402
         (multiple-value-prog1
             (values (notnot (packagep p))
                     (equalt (package-name p) "TEST1")
                     (equalt (package-nicknames p) nil)
                     (equalt (package-use-list p) (list (find-package name)))
                     (equalt (package-used-by-list p) nil))
             (safely-delete-package p))))
403
     t t t t t))
404 405 406 407 408 409

(def-make-package-test3 make-package.28
  (make-array 1 :initial-contents "A" :element-type 'base-char))

(def-make-package-test3 make-package.29
  (make-array 8 :initial-contents "Axxxyyyz"
sds's avatar
sds committed
410 411
              :fill-pointer 1
              :element-type 'base-char))
412 413 414

(def-make-package-test3 make-package.30
  (make-array 8 :initial-contents "Axxxyyyz"
sds's avatar
sds committed
415 416
              :fill-pointer 1
              :element-type 'character))
417 418 419

(def-make-package-test3 make-package.31
  (make-array 1 :initial-contents "A"
sds's avatar
sds committed
420 421
              :adjustable t
              :element-type 'base-char))
422 423 424

(def-make-package-test3 make-package.32
  (make-array 1 :initial-contents "A"
sds's avatar
sds committed
425 426
              :adjustable t
              :element-type 'character))
427 428 429

(def-make-package-test3 make-package.33
  (let* ((etype 'base-char)
sds's avatar
sds committed
430 431
         (name0 (make-array 10 :initial-contents "xxAyyy0123"
                            :element-type etype)))
432
    (make-array 1 :element-type etype
sds's avatar
sds committed
433 434
                :displaced-to name0
                :displaced-index-offset 2)))
435 436 437

(def-make-package-test3 make-package.34
  (let* ((etype 'character)
sds's avatar
sds committed
438 439
         (name0 (make-array 10 :initial-contents "xxAzzzzyyy"
                            :element-type etype)))
440
    (make-array 1 :element-type etype
sds's avatar
sds committed
441 442
                :displaced-to name0
                :displaced-index-offset 2)))
443

444 445 446
;; Signal a continuable error if the package or any nicknames
;; exist as packages or nicknames of packages

447
(deftest make-package.error.1
448 449 450
  (progn
    (set-up-packages)
    (handle-non-abort-restart (make-package "A")))
sds's avatar
sds committed
451
  success)
452

453
(deftest make-package.error.2
454 455 456
  (progn
    (set-up-packages)
    (handle-non-abort-restart (make-package "Q")))
457 458
  success)

459
(deftest make-package.error.3
460 461 462 463 464
  (progn
    (set-up-packages)
    (handle-non-abort-restart
     (safely-delete-package "TEST1")
     (make-package "TEST1" :nicknames '("A"))))
465
  success)
466

467
(deftest make-package.error.4
468
  (handle-non-abort-restart
469
   (safely-delete-package "TEST1")
pfdietz's avatar
pfdietz committed
470
   (set-up-packages)
471
   (make-package "TEST1" :nicknames '("Q")))
472
  success)
473 474

(deftest make-package.error.5
475 476
  (signals-error (make-package) program-error)
  t)
477 478 479

(deftest make-package.error.6
  (progn
480
    (safely-delete-package "MPE6")
481 482
    (signals-error (make-package "MPE6" :bad t) program-error))
  t)
483 484 485

(deftest make-package.error.7
  (progn
486
    (safely-delete-package "MPE7")
487 488
    (signals-error (make-package "MPE7" :nicknames) program-error))
  t)
489 490 491

(deftest make-package.error.8
  (progn
492
    (safely-delete-package "MPE8")
493 494
    (signals-error (make-package "MPE8" :use) program-error))
  t)
495 496 497

(deftest make-package.error.9
  (progn
498
    (safely-delete-package "MPE9")
499 500
    (signals-error (make-package "MPE9" 'bad t) program-error))
  t)
501 502 503

(deftest make-package.error.10
  (progn
504
    (safely-delete-package "MPE10")
505 506
    (signals-error (make-package "MPE10" 1 2) program-error))
  t)
507 508 509

(deftest make-package.error.11
  (progn
510
    (safely-delete-package "MPE11")
511
    (signals-error (make-package "MPE11" 'bad t :allow-other-keys nil)
sds's avatar
sds committed
512
                   program-error))
513
  t)