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

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

Assorted cleanup:

In infrastructure:

  • add *test-verbose* and :verbose argument to do-test and do-tests. Avoid random output if false, only show failures
  • muffle-wawrnings and/or bind *suppress-compiler-warnings* in some tests that unavoidably generate them (mainly with duplicate typecase/case clauses)
  • Add record-source-file for tests so meta-. can find them
  • If *catch-errors* (or the :catch-errors arg) is :break, enter a breakloop when catch an error
  • Make test fns created by *compile-tests* have names, so can find them in backtraces
  • fix misc compiler warnings
  • Fixed cases of duplicate test numbers
  • Disable note :make-condition-with-compound-name for openmcl.

In tests themselves:

I commented out the following tests with #+bogus-test, because they just seemed wrong to me:

lambda.47
lambda.50
upgraded-array-element-type.8
upgraded-array-element-type.nil.1
pathname-match-p.5
load.17
load.18
macrolet.47
ctypecase.15

In addition, I commented out the following tests with #+bogus-test because I was too lazy to make a note
for "doesn't signal underflow":

exp.error.8 exp.error.9 exp.error.10 exp.error.11 expt.error.8 expt.error.9 expt.error.10 expt.error.11

Finally, I entered bug reports in trac, and then commented out the tests
below with #+known-bug-NNN, where nnn is the ticket number in trac:

ticket#268: encode-universal-time.3 encode-universal-time.3.1
ticket#269: macrolet.36
ticket#270: values.20 values.21
ticket#271: defclass.error.13 defclass.error.22
ticket#272: phase.10 phase.12 asin.5 asin.6 asin.8
ticket#273: phase.18 phase.19 acos.8
ticket#274: exp.error.4 exp.error.5 exp.error.6 exp.error.7
ticket#275: car.error.2 cdr.error.2
ticket#276: map.error.11
ticket#277: subtypep.cons.43
ticket#278: subtypep-function.3
ticket#279: subtypep-complex.8
ticket#280: open.output.19 open.io.19 file-position.8 file-length.4 file-length.5 read-byte.4 stream-element-type.2 stream-element-type.3
ticket#281: open.65
ticket#288: set-syntax-from-char.sharp.1

File size: 17.2 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                     (when *test-verbose*
543                       (format t "Making G1...~%"))
544                     (eval '(defpackage "G1"
545                              (:use)
546                              (:export "A" "B" "C")
547                              (:intern "D" "E" "F")))))
548                  (pg2
549                   (progn
550                     (when *test-verbose*
551                       (format t "Making G2...~%"))
552                     (eval '(defpackage "G2"
553                              (:use)
554                              (:export "A" "D" "G")
555                              (:intern "E" "H" "I")))))
556                  (pg3
557                   (progn
558                     (when *test-verbose*
559                       (format t "Making G3...~%"))
560                     (eval '(defpackage "G3"
561                              (:use)
562                              (:export "J" "K" "L")
563                              (:intern "M" "N" "O"))))))
564              (let ((p (eval (list* 'defpackage "H" (copy-tree args)))))
565                (prog
566                 ()
567                 (unless (packagep p) (return 1))
568                 (unless (equal (package-name p) "H") (return 2))
569                 (unless (equal (package-name pg1) "G1") (return 3))
570                 (unless (equal (package-name pg2) "G2") (return 4))
571                 (unless (equal (package-name pg3) "G3") (return 5))
572                 (unless
573                     (equal (sort (copy-list (package-nicknames p)) #'string<)
574                            '("H1" "H2"))
575                   (return 6))
576                 (unless
577                     (or
578                      (equal (package-use-list p) (list pg1 pg2))
579                      (equal (package-use-list p) (list pg2 pg1)))
580                   (return 7))
581                 (unless (equal (package-used-by-list pg1) (list p))
582                   (return 8))
583                 (unless (equal (package-used-by-list pg2) (list p))
584                   (return 9))
585                 (when (package-used-by-list pg3) (return 10))
586                 (unless (equal (sort (mapcar #'symbol-name
587                                              (package-shadowing-symbols p))
588                                      #'string<)
589                                '("A" "B"))
590                   (return 10))
591                 (let ((num 11))
592                   (unless
593                       (every
594                        #'(lambda (str acc pkg)
595                            (multiple-value-bind*
596                             (sym access)
597                             (find-symbol str p)
598                             (or
599                              (and (or (not acc) (equal (symbol-name sym) str))
600                                   (or (not acc) (equal (symbol-package sym) pkg))
601                                   (equal access acc)
602                                   (incf num))
603                              (progn
604                                (format t
605                                        "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%"
606                                        str acc pkg sym access)
607                                nil))))
608                        (list "A" "B" "C" "D" "E" "F" "G"
609                              "H" "I" "J" "K" "L" "M" "N" "O")
610                        (list :internal :internal
611                              :external :inherited
612                              nil nil
613                              :inherited :internal
614                              nil nil
615                              nil :external
616                              nil nil
617                              :internal)
618                        (list pg2 p pg1 pg2 nil nil
619                              pg2 p nil nil nil pg3
620                              nil nil pg3))
621                     (return num)))
622                 (return 'success))))))
623        (let ((args '((:nicknames "H1" "H2")
624                      (:use "G1" "G2")
625                      (:shadow "B")
626                      (:shadowing-import-from "G2" "A")
627                      (:import-from "G3" "L" "O")
628                      (:intern "D" "H")
629                      (:export "L" "C")
630                      (:size 20)
631                      (:documentation "A test package"))))
632          (list (%do-it% args)
633                (%do-it% (reverse args)))))))
634  (success success))
635
636(def-macro-test defpackage.error.1
637  (defpackage :nonexistent-package (:use)))
Note: See TracBrowser for help on using the repository browser.