/[gcl]/gcl/ansi-tests/packages-16.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/packages-16.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by pfdietz, Sun Apr 20 22:59:26 2003 UTC revision 1.12 by pfdietz, Sat Jul 12 13:46:01 2003 UTC
# Line 59  Line 59 
59  ;; Test defpackage with documentation option  ;; Test defpackage with documentation option
60  ;; Do not check use-list, because it is implementation dependent  ;; Do not check use-list, because it is implementation dependent
61  (deftest defpackage.3  (deftest defpackage.3
62    (progn    (let ()
63      (safely-delete-package "H")      (safely-delete-package "H")
64      (ignore-errors      (ignore-errors
65        (let ((p (eval '(defpackage "H" (:documentation "This is a doc string")))))        (let ((p (eval '(defpackage "H" (:documentation "This is a doc string")))))
# Line 104  Line 104 
104    
105  ;; Test defpackage shadow option, and null use  ;; Test defpackage shadow option, and null use
106  (deftest defpackage.5  (deftest defpackage.5
107    (progn    (let ()
108      (safely-delete-package "H")      (safely-delete-package "H")
109      (ignore-errors      (ignore-errors
110        (let ((p (ignore-errors (eval `(defpackage "H" (:use)        (let ((p (ignore-errors (eval `(defpackage "H" (:use)
# Line 329  Line 329 
329  ;; Test defpackage with size  ;; Test defpackage with size
330    
331  (deftest defpackage.11  (deftest defpackage.11
332    (ignore-errors    (let ()
333      (safely-delete-package "H")      (ignore-errors
334      (let ((p (ignore-errors        (safely-delete-package "H")
335                 (eval '(defpackage "H" (:use) (:size 0))))))        (let ((p (ignore-errors
336        (mapcar                   (eval '(defpackage "H" (:use) (:size 0))))))
337         #'notnot          (mapcar
338         (list           #'notnot
339          (packagep p)           (list
340          (equal (package-name p)              "H")            (packagep p)
341          (equal (package-use-list p)          nil)            (equal (package-name p)              "H")
342          (equal (package-used-by-list p)      nil)            (equal (package-use-list p)          nil)
343          (equal (package-nicknames p)         nil)            (equal (package-used-by-list p)      nil)
344          (equal (package-shadowing-symbols p) nil)            (equal (package-nicknames p)         nil)
345          (zerop (num-symbols-in-package p))))))            (equal (package-shadowing-symbols p) nil)
346              (zerop (num-symbols-in-package p)))))))
347    (t t t t t t t))    (t t t t t t t))
348    
349  (deftest defpackage.12  (deftest defpackage.12
350    (ignore-errors    (let ()
351      (safely-delete-package "H")      (ignore-errors
352      (let ((p (ignore-errors        (safely-delete-package "H")
353                 (eval '(defpackage "H" (:use) (:size 10000))))))        (let ((p (ignore-errors
354        (mapcar                   (eval '(defpackage "H" (:use) (:size 10000))))))
355         #'notnot          (mapcar
356         (list           #'notnot
357          (packagep p)           (list
358          (equal (package-name p)              "H")            (packagep p)
359          (equal (package-use-list p)          nil)            (equal (package-name p)              "H")
360          (equal (package-used-by-list p)      nil)            (equal (package-use-list p)          nil)
361          (equal (package-nicknames p)         nil)            (equal (package-used-by-list p)      nil)
362          (equal (package-shadowing-symbols p) nil)            (equal (package-nicknames p)         nil)
363          (zerop (num-symbols-in-package p))))))            (equal (package-shadowing-symbols p) nil)
364              (zerop (num-symbols-in-package p)))))))
365    (t t t t t t t))    (t t t t t t t))
366    
367  ;; defpackage error handling  ;; defpackage error handling
# Line 512  Line 514 
514  ;; A big test that combines all the options to defpackage  ;; A big test that combines all the options to defpackage
515    
516  (deftest defpackage.26  (deftest defpackage.26
517    (ignore-errors    (let ()
518      (flet      (ignore-errors
519          ((%do-it%        (flet
520            (args)            ((%do-it%
521            (safely-delete-package "H")              (args)
522            (safely-delete-package "G1")              (safely-delete-package "H")
523            (safely-delete-package "G2")              (safely-delete-package "G1")
524            (safely-delete-package "G3")              (safely-delete-package "G2")
525            (let ((pg1              (safely-delete-package "G3")
526                   (progn              (let ((pg1
527                     (format t "Making G1...~%")                     (progn
528                     (eval '(defpackage "G1"                       (format t "Making G1...~%")
529                              (:use)                       (eval '(defpackage "G1"
530                              (:export "A" "B" "C")                                (:use)
531                              (:intern "D" "E" "F")))))                                (:export "A" "B" "C")
532                  (pg2                                (:intern "D" "E" "F")))))
533                   (progn                    (pg2
534                     (format t "Making G2...~%")                     (progn
535                     (eval '(defpackage "G2"                       (format t "Making G2...~%")
536                              (:use)                       (eval '(defpackage "G2"
537                              (:export "A" "D" "G")                                (:use)
538                              (:intern "E" "H" "I")))))                                (:export "A" "D" "G")
539                  (pg3                                (:intern "E" "H" "I")))))
540                   (progn                    (pg3
541                     (format t "Making G3...~%")                     (progn
542                     (eval '(defpackage "G3"                       (format t "Making G3...~%")
543                              (:use)                       (eval '(defpackage "G3"
544                              (:export "J" "K" "L")                                (:use)
545                              (:intern "M" "N" "O"))))))                                (:export "J" "K" "L")
546              (let ((p (eval (list* 'defpackage "H" (copy-tree args)))))                                (:intern "M" "N" "O"))))))
547                (prog                (let ((p (eval (list* 'defpackage "H" (copy-tree args)))))
548                 ()                  (prog
549                 (unless (packagep p) (return 1))                   ()
550                 (unless (equal (package-name p) "H") (return 2))                   (unless (packagep p) (return 1))
551                 (unless (equal (package-name pg1) "G1") (return 3))                   (unless (equal (package-name p) "H") (return 2))
552                 (unless (equal (package-name pg2) "G2") (return 4))                   (unless (equal (package-name pg1) "G1") (return 3))
553                 (unless (equal (package-name pg3) "G3") (return 5))                   (unless (equal (package-name pg2) "G2") (return 4))
554                 (unless                   (unless (equal (package-name pg3) "G3") (return 5))
555                     (equal (sort (copy-list (package-nicknames p)) #'string<)                   (unless
556                            '("H1" "H2"))                       (equal (sort (copy-list (package-nicknames p)) #'string<)
557                   (return 6))                              '("H1" "H2"))
558                 (unless                     (return 6))
                    (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))  
559                   (unless                   (unless
560                       (every                       (or
561                        #'(lambda (str acc pkg)                        (equal (package-use-list p) (list pg1 pg2))
562                            (multiple-value-bind*                        (equal (package-use-list p) (list pg2 pg1)))
563                                (sym access)                     (return 7))
564                                (find-symbol str p)                   (unless (equal (package-used-by-list pg1) (list p))
565                              (or                     (return 8))
566                               (and (or (not acc) (equal (symbol-name sym) str))                   (unless (equal (package-used-by-list pg2) (list p))
567                                    (or (not acc) (equal (symbol-package sym) pkg))                     (return 9))
568                                    (equal access acc)                   (when (package-used-by-list pg3) (return 10))
569                                    (incf num))                   (unless (equal (sort (mapcar #'symbol-name
570                               (progn                                                (package-shadowing-symbols p))
571                                 (format t                                        #'string<)
572                                         "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%"                                  '("A" "B"))
573                                         str acc pkg sym access)                     (return 10))
574                                 nil))))                   (let ((num 11))
575                        (list "A" "B" "C" "D" "E" "F" "G"                     (unless
576                              "H" "I" "J" "K" "L" "M" "N" "O")                         (every
577                        (list :internal :internal                          #'(lambda (str acc pkg)
578                              :external :inherited                              (multiple-value-bind*
579                              nil nil                               (sym access)
580                              :inherited :internal                               (find-symbol str p)
581                              nil nil                               (or
582                              nil :external                                (and (or (not acc) (equal (symbol-name sym) str))
583                              nil nil                                     (or (not acc) (equal (symbol-package sym) pkg))
584                              :internal)                                     (equal access acc)
585                        (list pg2 p pg1 pg2 nil nil                                     (incf num))
586                              pg2 p nil nil nil pg3                                (progn
587                              nil nil pg3))                                  (format t
588                     (return num)))                                          "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%"
589                 (return 'success))))))                                          str acc pkg sym access)
590        (let ((args '((:nicknames "H1" "H2")                                  nil))))
591                      (:use "G1" "G2")                          (list "A" "B" "C" "D" "E" "F" "G"
592                      (:shadow "B")                                "H" "I" "J" "K" "L" "M" "N" "O")
593                      (:shadowing-import-from "G2" "A")                          (list :internal :internal
594                      (:import-from "G3" "L" "O")                                :external :inherited
595                      (:intern "D" "H")                                nil nil
596                      (:export "L" "C")                                :inherited :internal
597                      (:size 20)                                nil nil
598                      (:documentation "A test package"))))                                nil :external
599          (list (%do-it% args)                                nil nil
600                (%do-it% (reverse args))))))                                :internal)
601                            (list pg2 p pg1 pg2 nil nil
602                                  pg2 p nil nil nil pg3
603                                  nil nil pg3))
604                         (return num)))
605                     (return 'success))))))
606            (let ((args '((:nicknames "H1" "H2")
607                          (:use "G1" "G2")
608                          (:shadow "B")
609                          (:shadowing-import-from "G2" "A")
610                          (:import-from "G3" "L" "O")
611                          (:intern "D" "H")
612                          (:export "L" "C")
613                          (:size 20)
614                          (:documentation "A test package"))))
615              (list (%do-it% args)
616                    (%do-it% (reverse args)))))))
617    (success success))    (success success))
618    
619  (def-macro-test defpackage.error.1  (def-macro-test defpackage.error.1

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26