source: trunk/source/tests/ansi-tests/defpackage.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 17.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 25 08:09:18 1998
4;;;; Contains: Tests of DEFPACKAGE
5
6(in-package :cl-test)
7
8(compile-and-load "package-aux.lsp")
9
10(declaim (optimize (safety 3)))
11
12;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13;;; defpackage
14
15;; Test basic defpackage call, with no options
16;; The use-list is implementation dependent, so
17;; we don't examine it here.
18;; Try several ways of specifying the package name.
19(deftest defpackage.1
20  (loop
21   for n in '("H" #:|H| #\H) count
22   (not
23    (progn
24      (safely-delete-package "H")
25      (let ((p (ignore-errors (eval `(defpackage ,n)))))
26        (and
27         (packagep p)
28         (equal (package-name p)              "H")
29         ;; (equal (package-use-list p)          nil)
30         (equal (package-used-by-list p)      nil)
31         (equal (package-nicknames p)         nil)
32         (equal (package-shadowing-symbols p) nil)
33         (null (documentation p t))
34         )))))
35  0)
36
37;; Test :nicknames option
38;; Do not check use-list, because it is implementation dependent
39;; Try several ways of specifying a nickname.
40(deftest defpackage.2
41  (loop
42   for n in '("I" #:|I| #\I) count
43   (not
44    (ignore-errors
45      (progn
46        (safely-delete-package "H")
47        (let ((p (ignore-errors
48                   (eval `(defpackage "H" (:nicknames ,n "J"))))))
49          (and
50           (packagep p)
51           (equal (package-name p)              "H")
52           ;; (equal (package-use-list p)          nil)
53           (equal (package-used-by-list p)      nil)
54           (equal (sort (copy-list (package-nicknames p))
55                        #'string<)
56                  '("I" "J"))
57           (equal (package-shadowing-symbols p) nil)
58           (null (documentation p t))
59           ))))))
60  0)
61
62;; Test defpackage with documentation option
63;; Do not check use-list, because it is implementation dependent
64(deftest defpackage.3
65  (let ()
66    (safely-delete-package "H")
67    (ignore-errors
68      (let ((p (eval '(defpackage "H" (:documentation "This is a doc string")))))
69        (and
70         (packagep p)
71         (equal (package-name p)              "H")
72         ;; (equal (package-use-list p)          nil)
73         (equal (package-used-by-list p)      nil)
74         (equal (package-nicknames p)   nil)
75         (equal (package-shadowing-symbols p) nil)
76         ;; The spec says implementations are free to discard
77         ;; documentations, so this next form was wrong.
78         ;; Instead, we'll just computation DOCUMENTATION
79         ;; and throw away the value.
80         ;; (equal (documentation p t) "This is a doc string")
81         (progn (documentation p t) t)
82         ))))
83  t)
84
85;; Check use argument
86;; Try several ways of specifying the package to be used
87(deftest defpackage.4
88  (progn
89    (set-up-packages)
90    (loop
91     for n in '("A" :|A| #\A) count
92     (not
93      (ignore-errors
94        (progn
95          (safely-delete-package "H")
96          (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n))))))
97            (and
98             (packagep p)
99             (equal (package-name p)              "H")
100             (equal (package-use-list p)          (list (find-package "A")))
101             (equal (package-used-by-list p)      nil)
102             (equal (package-nicknames p)         nil)
103             (equal (package-shadowing-symbols p) nil)
104             (eql (num-symbols-in-package p)
105                  (num-external-symbols-in-package "A"))
106             (equal (documentation p t)             nil)
107             )))))))
108  0)
109
110;; Test defpackage shadow option, and null use
111(deftest defpackage.5
112  (let ()
113    (safely-delete-package "H")
114    (ignore-errors
115      (let ((p (ignore-errors (eval `(defpackage "H" (:use)
116                                       (:shadow "foo"))))))
117        (mapcar
118         #'notnot
119         (list
120          (packagep p)
121          (equal (package-name p)              "H")
122          (equal (package-use-list p)          nil)
123          (equal (package-used-by-list p)      nil)
124          (equal (package-nicknames p)         nil)
125          (eql (num-symbols-in-package p) 1)
126          (multiple-value-bind* (sym access)
127              (find-symbol "foo" p)
128            (and (eqt access :internal)
129                 (equal (symbol-name sym) "foo")
130                 (equal (symbol-package sym) p)
131                 (equal (package-shadowing-symbols p)
132                        (list sym))))
133          (equal (documentation p t)             nil)
134         )))))
135  (t t t t t t t t))
136
137;; Test defpackage shadow and null use, with several ways
138;; of specifying the name of the shadowed symbol
139(deftest defpackage.6
140  (loop
141   for s in '(:|f| #\f)
142   collect
143   (ignore-errors
144     (safely-delete-package "H")
145     (let ((p (ignore-errors (eval `(defpackage "H"
146                                      (:use)
147                                      (:shadow ,s))))))
148       (mapcar
149        #'notnot
150        (list
151         (packagep p)
152         (equal (package-name p)              "H")
153         (equal (package-use-list p)          nil)
154         (equal (package-used-by-list p)      nil)
155         (equal (package-nicknames p)         nil)
156         (eql (num-symbols-in-package p) 1)
157         (multiple-value-bind* (sym access)
158             (find-symbol "f" p)
159           (and (eqt access :internal)
160                (equal (symbol-name sym) "f")
161                (equal (symbol-package sym) p)
162                (equal (package-shadowing-symbols p)
163                       (list sym))))
164         (equal (documentation p t)             nil)
165         )))))
166  ((t t t t t t t t)
167   (t t t t t t t t)))
168
169
170;; Testing defpackage with shadowing-import-from.
171;; Test several ways of specifying the symbol name
172(deftest defpackage.7
173  (progn
174    (safely-delete-package "H")
175    (safely-delete-package "G")
176    (let ((pg (make-package "G" :use nil)))
177      ;; Populate package G with several symbols
178      (export (intern "A" pg) pg)
179      (export (intern "foo" pg) pg)
180      (intern "bar" pg)
181      ;; Do test with several ways of specifying the
182      ;; shadowing-imported symbol
183      (loop
184       for n in '("A" :|A| #\A)
185       collect
186       (ignore-errors
187         (safely-delete-package "H")
188         (let ((p (ignore-errors
189                    (eval
190                     `(defpackage "H"
191                        (:use)
192                        (:shadowing-import-from "G" ,n))))))
193           (mapcar
194            #'notnot
195            (list
196             (packagep p)
197             (equal (package-name p)              "H")
198             (equal (package-use-list p)          nil)
199             (equal (package-used-by-list p)      nil)
200             (equal (package-nicknames p)         nil)
201             (eql (num-symbols-in-package p) 1)
202             (multiple-value-bind* (sym access)
203                 (find-symbol "A" p)
204               (and (eqt access :internal)
205                    (equal (symbol-name sym) "A")
206                    (equal (symbol-package sym) pg)
207                    (equal (package-shadowing-symbols p)
208                           (list sym))))
209             (equal (documentation p t)             nil)
210             )))))))
211  ((t t t t t t t t)
212   (t t t t t t t t)
213   (t t t t t t t t)))
214
215;; Test import-from option
216;; Test for each way of specifying the imported symbol name,
217;;  and for each way of specifying the package name from which
218;;   the symbol is imported
219(deftest defpackage.8
220    (progn
221      (safely-delete-package "H")
222      (safely-delete-package "G")
223      (let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C")))))
224        (loop
225          for pn in '("G" #:|G| #\G)
226          collect
227          (loop
228           for n in '("B" #:|B| #\B)
229           collect
230           (ignore-errors
231             (safely-delete-package "H")
232             (let ((p (ignore-errors
233                        (eval `(defpackage
234                                 "H" (:use)
235                                 (:import-from ,pn ,n "A"))))))
236               (mapcar
237                #'notnot
238                (list
239                 (packagep p)
240                 (equal (package-name p)              "H")
241                 (equal (package-use-list p)          nil)
242                 (equal (package-used-by-list p)      nil)
243                 (equal (package-nicknames p)         nil)
244                 (equal (package-shadowing-symbols p) nil)
245                 (eql (num-symbols-in-package p) 2)
246                 (multiple-value-bind* (sym access)
247                     (find-symbol "A" p)
248                   (and (eqt access :internal)
249                        (equal (symbol-name sym) "A")
250                        (equal (symbol-package sym) pg)))
251                 (multiple-value-bind* (sym access)
252                     (find-symbol "B" p)
253                   (and (eqt access :internal)
254                        (equal (symbol-name sym) "B")
255                        (equal (symbol-package sym) pg)))
256                 (equal (documentation p t)             nil)
257                 ))))))))
258    (((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))
259     ((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))
260     ((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))))
261
262;; Test defpackage with export option
263
264(deftest defpackage.9
265  (progn
266    (loop
267     for n in '("Z" #:|Z| #\Z)
268     collect
269     (ignore-errors
270       (safely-delete-package "H")
271       (let ((p (ignore-errors
272                  (eval `(defpackage
273                           "H"
274                           (:export "Q" ,n "R") (:use))))))
275         (mapcar
276          #'notnot
277          (list
278           (packagep p)
279           (equal (package-name p)              "H")
280           (equal (package-use-list p)          nil)
281           (equal (package-used-by-list p)      nil)
282           (equal (package-nicknames p)         nil)
283           (equal (package-shadowing-symbols p) nil)
284           (eql (num-symbols-in-package p) 3)
285           (loop
286            for s in '("Q" "Z" "R") do
287            (unless
288                (multiple-value-bind* (sym access)
289                    (find-symbol s p)
290                  (and (eqt access :external)
291                       (equal (symbol-name sym) s)
292                       (equal (symbol-package sym) p)))
293              (return nil))
294            finally (return t))
295           ))))))
296  ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t)))
297
298;; Test defpackage with the intern option
299
300(deftest defpackage.10
301  (progn
302    (loop
303     for n in '("Z" #:|Z| #\Z)
304     collect
305     (ignore-errors
306       (safely-delete-package "H")
307       (let ((p (ignore-errors
308                  (eval `(defpackage
309                           "H"
310                           (:intern "Q" ,n "R") (:use))))))
311         (mapcar
312          #'notnot
313          (list
314           (packagep p)
315           (equal (package-name p)              "H")
316           (equal (package-use-list p)          nil)
317           (equal (package-used-by-list p)      nil)
318           (equal (package-nicknames p)         nil)
319           (equal (package-shadowing-symbols p) nil)
320           (eql (num-symbols-in-package p) 3)
321           (loop
322            for s in '("Q" "Z" "R") do
323            (unless
324                (multiple-value-bind* (sym access)
325                    (find-symbol s p)
326                  (and (eqt access :internal)
327                       (equal (symbol-name sym) s)
328                       (equal (symbol-package sym) p)))
329              (return nil))
330            finally (return t))
331           ))))))
332  ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t)))
333
334;; Test defpackage with size
335
336(deftest defpackage.11
337  (let ()
338    (ignore-errors
339      (safely-delete-package "H")
340      (let ((p (ignore-errors
341                 (eval '(defpackage "H" (:use) (:size 0))))))
342        (mapcar
343         #'notnot
344         (list
345          (packagep p)
346          (equal (package-name p)              "H")
347          (equal (package-use-list p)          nil)
348          (equal (package-used-by-list p)      nil)
349          (equal (package-nicknames p)         nil)
350          (equal (package-shadowing-symbols p) nil)
351          (zerop (num-symbols-in-package p)))))))
352  (t t t t t t t))
353
354(deftest defpackage.12
355  (let ()
356    (ignore-errors
357      (safely-delete-package "H")
358      (let ((p (ignore-errors
359                 (eval '(defpackage "H" (:use) (:size 10000))))))
360        (mapcar
361         #'notnot
362         (list
363          (packagep p)
364          (equal (package-name p)              "H")
365          (equal (package-use-list p)          nil)
366          (equal (package-used-by-list p)      nil)
367          (equal (package-nicknames p)         nil)
368          (equal (package-shadowing-symbols p) nil)
369          (zerop (num-symbols-in-package p)))))))
370  (t t t t t t t))
371
372;; defpackage error handling
373
374;; Repeated size field should cause a program-error
375(deftest defpackage.13
376  (progn
377    (safely-delete-package "H")
378    (signals-error
379     (defpackage "H" (:use) (:size 10) (:size 20))
380     program-error))
381  t)
382
383;; Repeated documentation field should cause a program-error
384(deftest defpackage.14
385  (progn
386    (safely-delete-package "H")
387    (signals-error
388     (defpackage "H" (:use)
389       (:documentation "foo")
390       (:documentation "bar"))
391     program-error))
392  t)
393
394;; When a nickname refers to an existing package or nickname,
395;; signal a package-error
396
397(deftest defpackage.15
398  (progn
399    (safely-delete-package "H")
400    (signals-error
401     (defpackage "H" (:use) (:nicknames "A"))
402     package-error))
403  t)
404
405(deftest defpackage.16
406  (progn
407    (safely-delete-package "H")
408    (signals-error
409     (defpackage "H" (:use) (:nicknames "Q"))
410     package-error))
411  t)
412
413;; Names in :shadow, :shadowing-import-from, :import-from, and :intern
414;; must be disjoint, or a package-error is signalled.
415
416;; :shadow and :shadowing-import-from
417(deftest defpackage.17
418  (progn
419    (safely-delete-package "H")
420    (safely-delete-package "G")
421    (eval '(defpackage "G" (:use) (:export "A")))
422    (signals-error
423     (defpackage "H" (:use)
424       (:shadow "A")
425       (:shadowing-import-from "G" "A"))
426     program-error))
427  t)
428
429;; :shadow and :import-from
430(deftest defpackage.18
431  (progn
432    (safely-delete-package "H")
433    (safely-delete-package "G")
434    (eval '(defpackage "G" (:use) (:export "A")))
435    (signals-error
436     (defpackage "H" (:use)
437       (:shadow "A")
438       (:import-from "G" "A"))
439     program-error))
440  t)
441
442;; :shadow and :intern
443(deftest defpackage.19
444  (progn
445    (safely-delete-package "H")
446    (signals-error
447     (defpackage "H" (:use)
448       (:shadow "A")
449       (:intern "A"))
450     program-error))
451  t)
452
453;; :shadowing-import-from and :import-from
454(deftest defpackage.20
455  (progn
456    (safely-delete-package "H")
457    (safely-delete-package "G")
458    (eval '(defpackage "G" (:use) (:export "A")))
459    (signals-error
460     (defpackage "H" (:use)
461       (:shadowing-import-from "G" "A")
462       (:import-from "G" "A"))
463     program-error))
464  t)
465
466;; :shadowing-import-from and :intern
467(deftest defpackage.21
468  (progn
469    (safely-delete-package "H")
470    (safely-delete-package "G")
471    (eval '(defpackage "G" (:use) (:export "A")))
472    (signals-error
473     (defpackage "H" (:use)
474       (:shadowing-import-from "G" "A")
475       (:intern "A"))
476     program-error))
477  t)
478
479;; :import-from and :intern
480(deftest defpackage.22
481  (progn
482    (safely-delete-package "H")
483    (safely-delete-package "G")
484    (eval '(defpackage "G" (:use) (:export "A")))
485    (signals-error
486     (defpackage "H" (:use)
487       (:import-from "G" "A")
488       (:intern "A"))
489     program-error))
490  t)
491
492;; Names given to :export and :intern must be disjoint,
493;;  otherwise signal a program-error
494(deftest defpackage.23
495  (progn
496    (safely-delete-package "H")
497    (signals-error
498     (defpackage "H" (:use)
499       (:export "A")
500       (:intern "A"))
501     program-error))
502  t)
503
504;; :shadowing-import-from signals a correctable package-error
505;;  if the symbol is not accessible in the named package
506(deftest defpackage.24
507  (progn
508    (safely-delete-package "H")
509    (safely-delete-package "G")
510    (eval '(defpackage "G" (:use)))
511    (handle-non-abort-restart
512     (eval '(defpackage "H" (:shadowing-import-from
513                             "G" "NOT-THERE")))))
514  success)
515
516;; :import-from signals a correctable package-error if a symbol with
517;; the indicated name is not accessible in the package indicated
518
519(deftest defpackage.25
520  (progn
521    (safely-delete-package "H")
522    (safely-delete-package "G")
523    (eval '(defpackage "G" (:use)))
524    (handle-non-abort-restart
525     (eval '(defpackage "H" (:import-from "G" "NOT-THERE")))))
526  success)
527
528;; A big test that combines all the options to defpackage
529
530(deftest defpackage.26
531  (let ()
532    (ignore-errors
533      (flet
534          ((%do-it%
535            (args)
536            (safely-delete-package "H")
537            (safely-delete-package "G1")
538            (safely-delete-package "G2")
539            (safely-delete-package "G3")
540            (let ((pg1
541                   (progn
542                     (format t "Making G1...~%")
543                     (eval '(defpackage "G1"
544                              (:use)
545                              (:export "A" "B" "C")
546                              (:intern "D" "E" "F")))))
547                  (pg2
548                   (progn
549                     (format t "Making G2...~%")
550                     (eval '(defpackage "G2"
551                              (:use)
552                              (:export "A" "D" "G")
553                              (:intern "E" "H" "I")))))
554                  (pg3
555                   (progn
556                     (format t "Making G3...~%")
557                     (eval '(defpackage "G3"
558                              (:use)
559                              (:export "J" "K" "L")
560                              (:intern "M" "N" "O"))))))
561              (let ((p (eval (list* 'defpackage "H" (copy-tree args)))))
562                (prog
563                 ()
564                 (unless (packagep p) (return 1))
565                 (unless (equal (package-name p) "H") (return 2))
566                 (unless (equal (package-name pg1) "G1") (return 3))
567                 (unless (equal (package-name pg2) "G2") (return 4))
568                 (unless (equal (package-name pg3) "G3") (return 5))
569                 (unless
570                     (equal (sort (copy-list (package-nicknames p)) #'string<)
571                            '("H1" "H2"))
572                   (return 6))
573                 (unless
574                     (or
575                      (equal (package-use-list p) (list pg1 pg2))
576                      (equal (package-use-list p) (list pg2 pg1)))
577                   (return 7))
578                 (unless (equal (package-used-by-list pg1) (list p))
579                   (return 8))
580                 (unless (equal (package-used-by-list pg2) (list p))
581                   (return 9))
582                 (when (package-used-by-list pg3) (return 10))
583                 (unless (equal (sort (mapcar #'symbol-name
584                                              (package-shadowing-symbols p))
585                                      #'string<)
586                                '("A" "B"))
587                   (return 10))
588                 (let ((num 11))
589                   (unless
590                       (every
591                        #'(lambda (str acc pkg)
592                            (multiple-value-bind*
593                             (sym access)
594                             (find-symbol str p)
595                             (or
596                              (and (or (not acc) (equal (symbol-name sym) str))
597                                   (or (not acc) (equal (symbol-package sym) pkg))
598                                   (equal access acc)
599                                   (incf num))
600                              (progn
601                                (format t
602                                        "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%"
603                                        str acc pkg sym access)
604                                nil))))
605                        (list "A" "B" "C" "D" "E" "F" "G"
606                              "H" "I" "J" "K" "L" "M" "N" "O")
607                        (list :internal :internal
608                              :external :inherited
609                              nil nil
610                              :inherited :internal
611                              nil nil
612                              nil :external
613                              nil nil
614                              :internal)
615                        (list pg2 p pg1 pg2 nil nil
616                              pg2 p nil nil nil pg3
617                              nil nil pg3))
618                     (return num)))
619                 (return 'success))))))
620        (let ((args '((:nicknames "H1" "H2")
621                      (:use "G1" "G2")
622                      (:shadow "B")
623                      (:shadowing-import-from "G2" "A")
624                      (:import-from "G3" "L" "O")
625                      (:intern "D" "H")
626                      (:export "L" "C")
627                      (:size 20)
628                      (:documentation "A test package"))))
629          (list (%do-it% args)
630                (%do-it% (reverse args)))))))
631  (success success))
632
633(def-macro-test defpackage.error.1
634  (defpackage :nonexistent-package (:use)))
Note: See TracBrowser for help on using the repository browser.