defpackage.lsp 21.6 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 08:09:18 1998
4
;;;; Contains: Tests of DEFPACKAGE
5

6

7

8

9

10 11 12 13 14 15 16 17 18
(declaim (optimize (safety 3)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; defpackage

;; Test basic defpackage call, with no options
;; The use-list is implementation dependent, so
;; we don't examine it here.
;; Try several ways of specifying the package name.
19
(deftest defpackage.1
20 21 22 23
  (loop
   for n in '("H" #:|H| #\H) count
   (not
    (progn
24
      (safely-delete-package "H")
25
      (let ((p (ignore-errors (eval `(defpackage ,n)))))
sds's avatar
sds committed
26 27 28 29 30 31 32 33 34
        (and
         (packagep p)
         (equal (package-name p)              "H")
         ;; (equal (package-use-list p)          nil)
         (equal (package-used-by-list p)      nil)
         (equal (package-nicknames p)         nil)
         (equal (package-shadowing-symbols p) nil)
         (null (documentation p t))
         )))))
35 36 37 38 39
  0)

;; Test :nicknames option
;; Do not check use-list, because it is implementation dependent
;; Try several ways of specifying a nickname.
40
(deftest defpackage.2
41 42 43 44 45
  (loop
   for n in '("I" #:|I| #\I) count
   (not
    (ignore-errors
      (progn
sds's avatar
sds committed
46 47 48 49 50 51 52 53 54 55 56 57 58 59
        (safely-delete-package "H")
        (let ((p (ignore-errors
                   (eval `(defpackage "H" (:nicknames ,n "J"))))))
          (and
           (packagep p)
           (equal (package-name p)              "H")
           ;; (equal (package-use-list p)          nil)
           (equal (package-used-by-list p)      nil)
           (equal (sort (copy-list (package-nicknames p))
                        #'string<)
                  '("I" "J"))
           (equal (package-shadowing-symbols p) nil)
           (null (documentation p t))
           ))))))
60
  0)
61

62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
;;; Test :nicknames option with more than one occurrence.
;;; Do not check use-list, because it is implementation dependent
;;; Try several ways of specifying a nickname.
(deftest defpackage.2b
  (loop
   for n in '("I" #:|I| #\I) count
   (not
    (ignore-errors
      (progn
        (safely-delete-package "H")
        (let ((p (ignore-errors
                   (eval `(defpackage "H"
			    (:nicknames ,n)
			    (:nicknames "J"))))))
          (and
           (packagep p)
           (equal (package-name p)              "H")
           (equal (package-used-by-list p)      nil)
           (equal (sort (copy-list (package-nicknames p))
                        #'string<)
                  '("I" "J"))
           (equal (package-shadowing-symbols p) nil)
           (null (documentation p t))))))))
  0)

87 88
;; Test defpackage with documentation option
;; Do not check use-list, because it is implementation dependent
89
(deftest defpackage.3
90
  (let ()
91
    (safely-delete-package "H")
92 93
    (ignore-errors
      (let ((p (eval '(defpackage "H" (:documentation "This is a doc string")))))
sds's avatar
sds committed
94 95 96 97 98 99 100 101 102 103 104 105 106 107
        (and
         (packagep p)
         (equal (package-name p)              "H")
         ;; (equal (package-use-list p)          nil)
         (equal (package-used-by-list p)      nil)
         (equal (package-nicknames p)   nil)
         (equal (package-shadowing-symbols p) nil)
         ;; The spec says implementations are free to discard
         ;; documentations, so this next form was wrong.
         ;; Instead, we'll just computation DOCUMENTATION
         ;; and throw away the value.
         ;; (equal (documentation p t) "This is a doc string")
         (progn (documentation p t) t)
         ))))
108 109 110 111
  t)

;; Check use argument
;; Try several ways of specifying the package to be used
112
(deftest defpackage.4
113 114 115 116 117 118
  (progn
    (set-up-packages)
    (loop
     for n in '("A" :|A| #\A) count
     (not
      (ignore-errors
sds's avatar
sds committed
119 120 121 122 123 124 125 126 127 128 129 130 131 132
        (progn
          (safely-delete-package "H")
          (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n))))))
            (and
             (packagep p)
             (equal (package-name p)              "H")
             (equal (package-use-list p)          (list (find-package "A")))
             (equal (package-used-by-list p)      nil)
             (equal (package-nicknames p)         nil)
             (equal (package-shadowing-symbols p) nil)
             (eql (num-symbols-in-package p)
                  (num-external-symbols-in-package "A"))
             (equal (documentation p t)             nil)
             )))))))
133 134 135
  0)

;; Test defpackage shadow option, and null use
136
(deftest defpackage.5
137
  (let ()
138
    (safely-delete-package "H")
139
    (ignore-errors
sds's avatar
sds committed
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
      (let ((p (ignore-errors (eval `(defpackage "H" (:use)
                                       (:shadow "foo"))))))
        (mapcar
         #'notnot
         (list
          (packagep p)
          (equal (package-name p)              "H")
          (equal (package-use-list p)          nil)
          (equal (package-used-by-list p)      nil)
          (equal (package-nicknames p)         nil)
          (eql (num-symbols-in-package p) 1)
          (multiple-value-bind* (sym access)
              (find-symbol "foo" p)
            (and (eqt access :internal)
                 (equal (symbol-name sym) "foo")
                 (equal (symbol-package sym) p)
                 (equal (package-shadowing-symbols p)
                        (list sym))))
          (equal (documentation p t)             nil)
         )))))
160
  (t t t t t t t t))
161 162 163

;; Test defpackage shadow and null use, with several ways
;; of specifying the name of the shadowed symbol
164
(deftest defpackage.6
165 166 167 168
  (loop
   for s in '(:|f| #\f)
   collect
   (ignore-errors
169
     (safely-delete-package "H")
sds's avatar
sds committed
170 171 172
     (let ((p (ignore-errors (eval `(defpackage "H"
                                      (:use)
                                      (:shadow ,s))))))
173
       (mapcar
sds's avatar
sds committed
174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
        #'notnot
        (list
         (packagep p)
         (equal (package-name p)              "H")
         (equal (package-use-list p)          nil)
         (equal (package-used-by-list p)      nil)
         (equal (package-nicknames p)         nil)
         (eql (num-symbols-in-package p) 1)
         (multiple-value-bind* (sym access)
             (find-symbol "f" p)
           (and (eqt access :internal)
                (equal (symbol-name sym) "f")
                (equal (symbol-package sym) p)
                (equal (package-shadowing-symbols p)
                       (list sym))))
         (equal (documentation p t)             nil)
         )))))
191 192
  ((t t t t t t t t)
   (t t t t t t t t)))
193 194 195 196


;; Testing defpackage with shadowing-import-from.
;; Test several ways of specifying the symbol name
197
(deftest defpackage.7
198
  (progn
199 200
    (safely-delete-package "H")
    (safely-delete-package "G")
201 202 203 204 205 206 207 208 209 210 211
    (let ((pg (make-package "G" :use nil)))
      ;; Populate package G with several symbols
      (export (intern "A" pg) pg)
      (export (intern "foo" pg) pg)
      (intern "bar" pg)
      ;; Do test with several ways of specifying the
      ;; shadowing-imported symbol
      (loop
       for n in '("A" :|A| #\A)
       collect
       (ignore-errors
sds's avatar
sds committed
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
         (safely-delete-package "H")
         (let ((p (ignore-errors
                    (eval
                     `(defpackage "H"
                        (:use)
                        (:shadowing-import-from "G" ,n))))))
           (mapcar
            #'notnot
            (list
             (packagep p)
             (equal (package-name p)              "H")
             (equal (package-use-list p)          nil)
             (equal (package-used-by-list p)      nil)
             (equal (package-nicknames p)         nil)
             (eql (num-symbols-in-package p) 1)
             (multiple-value-bind* (sym access)
                 (find-symbol "A" p)
               (and (eqt access :internal)
                    (equal (symbol-name sym) "A")
                    (equal (symbol-package sym) pg)
                    (equal (package-shadowing-symbols p)
                           (list sym))))
             (equal (documentation p t)             nil)
             )))))))
236 237 238
  ((t t t t t t t t)
   (t t t t t t t t)
   (t t t t t t t t)))
239 240 241 242 243

;; Test import-from option
;; Test for each way of specifying the imported symbol name,
;;  and for each way of specifying the package name from which
;;   the symbol is imported
244
(deftest defpackage.8
245
    (progn
246 247
      (safely-delete-package "H")
      (safely-delete-package "G")
248
      (let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C")))))
sds's avatar
sds committed
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
        (loop
          for pn in '("G" #:|G| #\G)
          collect
          (loop
           for n in '("B" #:|B| #\B)
           collect
           (ignore-errors
             (safely-delete-package "H")
             (let ((p (ignore-errors
                        (eval `(defpackage
                                 "H" (:use)
                                 (:import-from ,pn ,n "A"))))))
               (mapcar
                #'notnot
                (list
                 (packagep p)
                 (equal (package-name p)              "H")
                 (equal (package-use-list p)          nil)
                 (equal (package-used-by-list p)      nil)
                 (equal (package-nicknames p)         nil)
                 (equal (package-shadowing-symbols p) nil)
                 (eql (num-symbols-in-package p) 2)
                 (multiple-value-bind* (sym access)
                     (find-symbol "A" p)
                   (and (eqt access :internal)
                        (equal (symbol-name sym) "A")
                        (equal (symbol-package sym) pg)))
                 (multiple-value-bind* (sym access)
                     (find-symbol "B" p)
                   (and (eqt access :internal)
                        (equal (symbol-name sym) "B")
                        (equal (symbol-package sym) pg)))
                 (equal (documentation p t)             nil)
                 ))))))))
pfdietz's avatar
pfdietz committed
283 284 285
    (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))
     ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))
     ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t))))
286 287 288

;; Test defpackage with export option

289
(deftest defpackage.9
290 291 292 293 294
  (progn
    (loop
     for n in '("Z" #:|Z| #\Z)
     collect
     (ignore-errors
295
       (safely-delete-package "H")
296
       (let ((p (ignore-errors
sds's avatar
sds committed
297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320
                  (eval `(defpackage
                           "H"
                           (:export "Q" ,n "R") (:use))))))
         (mapcar
          #'notnot
          (list
           (packagep p)
           (equal (package-name p)              "H")
           (equal (package-use-list p)          nil)
           (equal (package-used-by-list p)      nil)
           (equal (package-nicknames p)         nil)
           (equal (package-shadowing-symbols p) nil)
           (eql (num-symbols-in-package p) 3)
           (loop
            for s in '("Q" "Z" "R") do
            (unless
                (multiple-value-bind* (sym access)
                    (find-symbol s p)
                  (and (eqt access :external)
                       (equal (symbol-name sym) s)
                       (equal (symbol-package sym) p)))
              (return nil))
            finally (return t))
           ))))))
321
  ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t)))
322 323 324

;; Test defpackage with the intern option

325
(deftest defpackage.10
326 327 328 329 330
  (progn
    (loop
     for n in '("Z" #:|Z| #\Z)
     collect
     (ignore-errors
331
       (safely-delete-package "H")
332
       (let ((p (ignore-errors
sds's avatar
sds committed
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
                  (eval `(defpackage
                           "H"
                           (:intern "Q" ,n "R") (:use))))))
         (mapcar
          #'notnot
          (list
           (packagep p)
           (equal (package-name p)              "H")
           (equal (package-use-list p)          nil)
           (equal (package-used-by-list p)      nil)
           (equal (package-nicknames p)         nil)
           (equal (package-shadowing-symbols p) nil)
           (eql (num-symbols-in-package p) 3)
           (loop
            for s in '("Q" "Z" "R") do
            (unless
                (multiple-value-bind* (sym access)
                    (find-symbol s p)
                  (and (eqt access :internal)
                       (equal (symbol-name sym) s)
                       (equal (symbol-package sym) p)))
              (return nil))
            finally (return t))
           ))))))
357
  ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t)))
358 359 360

;; Test defpackage with size

361
(deftest defpackage.11
362 363 364 365
  (let ()
    (ignore-errors
      (safely-delete-package "H")
      (let ((p (ignore-errors
sds's avatar
sds committed
366 367 368 369 370 371 372 373 374 375 376
                 (eval '(defpackage "H" (:use) (:size 0))))))
        (mapcar
         #'notnot
         (list
          (packagep p)
          (equal (package-name p)              "H")
          (equal (package-use-list p)          nil)
          (equal (package-used-by-list p)      nil)
          (equal (package-nicknames p)         nil)
          (equal (package-shadowing-symbols p) nil)
          (zerop (num-symbols-in-package p)))))))
377
  (t t t t t t t))
378

379
(deftest defpackage.12
380 381 382 383
  (let ()
    (ignore-errors
      (safely-delete-package "H")
      (let ((p (ignore-errors
sds's avatar
sds committed
384 385 386 387 388 389 390 391 392 393 394
                 (eval '(defpackage "H" (:use) (:size 10000))))))
        (mapcar
         #'notnot
         (list
          (packagep p)
          (equal (package-name p)              "H")
          (equal (package-use-list p)          nil)
          (equal (package-used-by-list p)      nil)
          (equal (package-nicknames p)         nil)
          (equal (package-shadowing-symbols p) nil)
          (zerop (num-symbols-in-package p)))))))
395
  (t t t t t t t))
396 397 398 399

;; defpackage error handling

;; Repeated size field should cause a program-error
400
(deftest defpackage.13
401
  (progn
402
    (safely-delete-package "H")
403 404 405 406
    (signals-error
     (defpackage "H" (:use) (:size 10) (:size 20))
     program-error))
  t)
407 408

;; Repeated documentation field should cause a program-error
409
(deftest defpackage.14
410
  (progn
411
    (safely-delete-package "H")
412 413 414 415 416 417
    (signals-error
     (defpackage "H" (:use)
       (:documentation "foo")
       (:documentation "bar"))
     program-error))
  t)
418 419

;; When a nickname refers to an existing package or nickname,
420
;; signal a package-error
421

422
(deftest defpackage.15
423
  (progn
424
    (safely-delete-package "H")
425 426 427 428
    (signals-error
     (defpackage "H" (:use) (:nicknames "A"))
     package-error))
  t)
429

430
(deftest defpackage.16
431
  (progn
432
    (safely-delete-package "H")
433 434 435 436
    (signals-error
     (defpackage "H" (:use) (:nicknames "Q"))
     package-error))
  t)
437 438 439 440 441

;; Names in :shadow, :shadowing-import-from, :import-from, and :intern
;; must be disjoint, or a package-error is signalled.

;; :shadow and :shadowing-import-from
442
(deftest defpackage.17
443
  (progn
444 445
    (safely-delete-package "H")
    (safely-delete-package "G")
446
    (eval '(defpackage "G" (:use) (:export "A")))
447 448 449 450 451 452
    (signals-error
     (defpackage "H" (:use)
       (:shadow "A")
       (:shadowing-import-from "G" "A"))
     program-error))
  t)
453 454

;; :shadow and :import-from
455
(deftest defpackage.18
456
  (progn
457 458
    (safely-delete-package "H")
    (safely-delete-package "G")
459
    (eval '(defpackage "G" (:use) (:export "A")))
460 461 462 463 464 465
    (signals-error
     (defpackage "H" (:use)
       (:shadow "A")
       (:import-from "G" "A"))
     program-error))
  t)
466 467

;; :shadow and :intern
468
(deftest defpackage.19
469
  (progn
470
    (safely-delete-package "H")
471 472 473 474 475 476
    (signals-error
     (defpackage "H" (:use)
       (:shadow "A")
       (:intern "A"))
     program-error))
  t)
477 478

;; :shadowing-import-from and :import-from
479
(deftest defpackage.20
480
  (progn
481 482
    (safely-delete-package "H")
    (safely-delete-package "G")
483
    (eval '(defpackage "G" (:use) (:export "A")))
484 485 486 487 488 489
    (signals-error
     (defpackage "H" (:use)
       (:shadowing-import-from "G" "A")
       (:import-from "G" "A"))
     program-error))
  t)
490 491

;; :shadowing-import-from and :intern
492
(deftest defpackage.21
493
  (progn
494 495
    (safely-delete-package "H")
    (safely-delete-package "G")
496
    (eval '(defpackage "G" (:use) (:export "A")))
497 498 499 500 501 502
    (signals-error
     (defpackage "H" (:use)
       (:shadowing-import-from "G" "A")
       (:intern "A"))
     program-error))
  t)
503 504

;; :import-from and :intern
505
(deftest defpackage.22
506
  (progn
507 508
    (safely-delete-package "H")
    (safely-delete-package "G")
509
    (eval '(defpackage "G" (:use) (:export "A")))
510 511 512 513 514 515
    (signals-error
     (defpackage "H" (:use)
       (:import-from "G" "A")
       (:intern "A"))
     program-error))
  t)
516 517

;; Names given to :export and :intern must be disjoint,
518
;;  otherwise signal a program-error
519
(deftest defpackage.23
520
  (progn
521
    (safely-delete-package "H")
522 523 524 525 526 527
    (signals-error
     (defpackage "H" (:use)
       (:export "A")
       (:intern "A"))
     program-error))
  t)
528 529 530

;; :shadowing-import-from signals a correctable package-error
;;  if the symbol is not accessible in the named package
531
(deftest defpackage.24
532
  (progn
533 534
    (safely-delete-package "H")
    (safely-delete-package "G")
535
    (eval '(defpackage "G" (:use)))
536 537
    (handle-non-abort-restart
     (eval '(defpackage "H" (:shadowing-import-from
sds's avatar
sds committed
538
                             "G" "NOT-THERE")))))
539 540 541 542 543
  success)

;; :import-from signals a correctable package-error if a symbol with
;; the indicated name is not accessible in the package indicated

544
(deftest defpackage.25
545
  (progn
546 547
    (safely-delete-package "H")
    (safely-delete-package "G")
548
    (eval '(defpackage "G" (:use)))
549 550
    (handle-non-abort-restart
     (eval '(defpackage "H" (:import-from "G" "NOT-THERE")))))
551 552 553 554
  success)

;; A big test that combines all the options to defpackage

555
(deftest defpackage.26
556 557 558
  (let ()
    (ignore-errors
      (flet
sds's avatar
sds committed
559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655
          ((%do-it%
            (args)
            (safely-delete-package "H")
            (safely-delete-package "G1")
            (safely-delete-package "G2")
            (safely-delete-package "G3")
            (let ((pg1
                   (progn
                     (format t "Making G1...~%")
                     (eval '(defpackage "G1"
                              (:use)
                              (:export "A" "B" "C")
                              (:intern "D" "E" "F")))))
                  (pg2
                   (progn
                     (format t "Making G2...~%")
                     (eval '(defpackage "G2"
                              (:use)
                              (:export "A" "D" "G")
                              (:intern "E" "H" "I")))))
                  (pg3
                   (progn
                     (format t "Making G3...~%")
                     (eval '(defpackage "G3"
                              (:use)
                              (:export "J" "K" "L")
                              (:intern "M" "N" "O"))))))
              (let ((p (eval (list* 'defpackage "H" (copy-tree args)))))
                (prog
                 ()
                 (unless (packagep p) (return 1))
                 (unless (equal (package-name p) "H") (return 2))
                 (unless (equal (package-name pg1) "G1") (return 3))
                 (unless (equal (package-name pg2) "G2") (return 4))
                 (unless (equal (package-name pg3) "G3") (return 5))
                 (unless
                     (equal (sort (copy-list (package-nicknames p)) #'string<)
                            '("H1" "H2"))
                   (return 6))
                 (unless
                     (or
                      (equal (package-use-list p) (list pg1 pg2))
                      (equal (package-use-list p) (list pg2 pg1)))
                   (return 7))
                 (unless (equal (package-used-by-list pg1) (list p))
                   (return 8))
                 (unless (equal (package-used-by-list pg2) (list p))
                   (return 9))
                 (when (package-used-by-list pg3) (return 10))
                 (unless (equal (sort (mapcar #'symbol-name
                                              (package-shadowing-symbols p))
                                      #'string<)
                                '("A" "B"))
                   (return 10))
                 (let ((num 11))
                   (unless
                       (every
                        #'(lambda (str acc pkg)
                            (multiple-value-bind*
                             (sym access)
                             (find-symbol str p)
                             (or
                              (and (or (not acc) (equal (symbol-name sym) str))
                                   (or (not acc) (equal (symbol-package sym) pkg))
                                   (equal access acc)
                                   (incf num))
                              (progn
                                (format t
                                        "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%"
                                        str acc pkg sym access)
                                nil))))
                        (list "A" "B" "C" "D" "E" "F" "G"
                              "H" "I" "J" "K" "L" "M" "N" "O")
                        (list :internal :internal
                              :external :inherited
                              nil nil
                              :inherited :internal
                              nil nil
                              nil :external
                              nil nil
                              :internal)
                        (list pg2 p pg1 pg2 nil nil
                              pg2 p nil nil nil pg3
                              nil nil pg3))
                     (return num)))
                 (return 'success))))))
        (let ((args '((:nicknames "H1" "H2")
                      (:use "G1" "G2")
                      (:shadow "B")
                      (:shadowing-import-from "G2" "A")
                      (:import-from "G3" "L" "O")
                      (:intern "D" "H")
                      (:export "L" "C")
                      (:size 20)
                      (:documentation "A test package"))))
          (list (%do-it% args)
                (%do-it% (reverse args)))))))
656
  (success success))
657 658

(def-macro-test defpackage.error.1
sds's avatar
sds committed
659
  (defpackage :nonexistent-package (:use)))