diff options
Diffstat (limited to 'Sacla/tests/must-package.lisp')
| -rw-r--r-- | Sacla/tests/must-package.lisp | 2266 |
1 files changed, 2266 insertions, 0 deletions
diff --git a/Sacla/tests/must-package.lisp b/Sacla/tests/must-package.lisp new file mode 100644 index 0000000..192c570 --- /dev/null +++ b/Sacla/tests/must-package.lisp @@ -0,0 +1,2266 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-package.lisp,v 1.12 2004/08/09 02:49:54 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +;; list-all-packages +(listp (list-all-packages)) +(find "COMMON-LISP" (mapcar #'package-name (list-all-packages)) :test #'string=) +(find "COMMON-LISP-USER" (mapcar #'package-name (list-all-packages)) :test #'string=) +(find "KEYWORD" (mapcar #'package-name (list-all-packages)) :test #'string=) +(every #'packagep (list-all-packages)) + + +;; find-package +(packagep (find-package "COMMON-LISP")) +(packagep (find-package "CL")) +(packagep (find-package "COMMON-LISP-USER")) +(packagep (find-package "CL-USER")) +(packagep (find-package "KEYWORD")) +(let ((cl (find-package "COMMON-LISP"))) + (eq cl (find-package cl))) +(eq (find-package "CL") (find-package "COMMON-LISP")) +(eq (find-package 'cl) (find-package "COMMON-LISP")) +(eq (find-package 'cl) (find-package 'common-lisp)) +(let ((name "NO-SUCH-PACKAGE")) + (when (find-package name) + (delete-package name)) + (not (find-package name))) +(= (length (multiple-value-list (find-package "CL"))) 1) +(= (length (multiple-value-list (find-package "NO-SUCH-PACKAGE"))) 1) +(packagep (find-package (find-package (find-package "KEYWORD")))) + + +;; packagep +(every (complement #'packagep) '(nil a b "CL" "KEYWORD" (a) cl common-lisp-user)) + +;; make-package +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package #\a)) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package '|a|)) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a")) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use nil)) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl))) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl) :nicknames '("b"))) + (delete-package "b"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl) :nicknames '("b" "c"))) + (delete-package "c"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl) :nicknames '(#\b "c"))) + (delete-package "b"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl) :nicknames '(|b| "c"))) + (delete-package "b"))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a")) + (WHEN (FIND-PACKAGE "b") (DELETE-PACKAGE "b")) + (AND (PACKAGEP (MAKE-PACKAGE "b" :USE '(CL))) + (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '(|b| "c"))))) + (ERROR NIL T) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a")) + (WHEN (FIND-PACKAGE "b") (DELETE-PACKAGE "b")) + (AND (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL))) + (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '(|b| "c"))))) + (ERROR NIL T) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a")) + (WHEN (FIND-PACKAGE "d") (DELETE-PACKAGE "b")) + (AND (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '("b" "c"))) + (PACKAGEP (MAKE-PACKAGE "d" :USE '(CL) :NICKNAMES '("c"))))) + (ERROR NIL T) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (AND (PACKAGEP (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL)) + (EXPORT (INTERN "CAR" 'TB-BAR-TO-USE) 'TB-BAR-TO-USE) + (MAKE-PACKAGE "TB-FOO" :USE '(CL "TB-BAR-TO-USE")))) + (ERROR NIL T) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +;; package-name +(string= (package-name "COMMON-LISP") "COMMON-LISP") +(string= (package-name 'common-lisp) "COMMON-LISP") +(string= (package-name (find-package 'common-lisp)) "COMMON-LISP") +(string= (package-name "CL") "COMMON-LISP") +(string= (package-name 'cl) "COMMON-LISP") +(string= (package-name (find-package 'cl)) "COMMON-LISP") +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'stringp (mapcar #'package-name designator-list))) +(every #'stringp (mapcar #'package-name (list-all-packages))) +(let* ((name "TB-FOO") + (package (or (find-package name) (make-package name :use nil)))) + (and (delete-package name) + (not (find-package name)) + (null (package-name package)))) + + +;; package-nicknames +(member "CL" (package-nicknames "COMMON-LISP") :test #'string=) +(member "CL" (package-nicknames 'common-lisp) :test #'string=) +(member "CL" (package-nicknames (find-package 'common-lisp)) :test #'string=) +(member "CL" (package-nicknames "CL") :test #'string=) +(member "CL" (package-nicknames 'cl) :test #'string=) +(member "CL" (package-nicknames (find-package 'cl)) :test #'string=) +(let ((name 'test-foo) + (nicknames '(test-foo-nickname1 test-foo-nickname2 test-foo-nickname3))) + (dolist (name (cons name nicknames)) + (when (find-package name) (delete-package name))) + (every #'stringp (package-nicknames (make-package name :nicknames nicknames)))) +(every #'stringp (mapcan #'(lambda (package) + (copy-list (package-nicknames package))) + (list-all-packages))) +(progn + (when (find-package 'test-foo) (delete-package 'test-foo)) + (null (set-difference + (package-nicknames (make-package 'test-foo + :nicknames '("TB-FOO" "test-foo"))) + '("TB-FOO" "test-foo") + :test #'string=))) +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'stringp (mapcan #'(lambda (designator) + (copy-list (package-nicknames designator))) + designator-list))) + + +;; package-shadowing-symbols +(every #'listp (mapcar #'package-shadowing-symbols (list-all-packages))) +(every #'symbolp (mapcan #'(lambda (package) + (copy-list (package-shadowing-symbols package))) + (list-all-packages))) +(listp (package-shadowing-symbols 'cl)) +(listp (package-shadowing-symbols "CL-USER")) +(listp (package-shadowing-symbols "COMMON-LISP")) +(listp (package-shadowing-symbols (find-package 'keyword))) +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'symbolp (mapcan #'(lambda (designator) + (copy-list (package-shadowing-symbols designator))) + designator-list))) + + +;; package-use-list +(every #'listp (mapcar #'package-use-list (list-all-packages))) +(every #'packagep (mapcan #'(lambda (package) + (copy-list (package-use-list package))) + (list-all-packages))) +(listp (package-use-list 'cl)) +(listp (package-use-list "CL-USER")) +(listp (package-use-list "COMMON-LISP")) +(listp (package-use-list (find-package 'keyword))) +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'packagep (mapcan #'(lambda (designator) + (copy-list (package-use-list designator))) + designator-list))) + + +;; package-used-by-list +(every #'listp (mapcar #'package-used-by-list (list-all-packages))) +(every #'packagep (mapcan #'(lambda (package) + (copy-list (package-used-by-list package))) + (list-all-packages))) +(listp (package-used-by-list 'cl)) +(listp (package-used-by-list "CL-USER")) +(listp (package-used-by-list "COMMON-LISP")) +(listp (package-used-by-list (find-package 'keyword))) +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'packagep (mapcan #'(lambda (designator) + (copy-list (package-used-by-list designator))) + designator-list))) + + +;; rename-package +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO" "TB-FOO-RENAMED")) + (let* ((package (make-package "TB-FOO" :use nil))) + (and (eq (rename-package "TB-FOO" "TB-FOO-RENAMED") package) + (eq (find-package "TB-FOO-RENAMED") package)))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" "TB-FOO-3" "TB-FOO-4")) + (let* ((package (make-package "TB-FOO-0" :use nil))) + (and (eq (rename-package "TB-FOO-0" "TB-FOO-1") package) + (eq (rename-package "TB-FOO-1" "TB-FOO-2") package) + (eq (rename-package "TB-FOO-2" "TB-FOO-3") package) + (eq (rename-package "TB-FOO-3" "TB-FOO-4") package) + (eq (find-package "TB-FOO-4") package)))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" "TB-FOO-3" "TB-FOO-4")) + (let* ((package (make-package "TB-FOO-0" :use nil))) + (and (eq (rename-package (find-package "TB-FOO-0") "TB-FOO-1") package) + (eq (rename-package (find-package "TB-FOO-1") "TB-FOO-2") package) + (eq (rename-package (find-package "TB-FOO-2") "TB-FOO-3") package) + (eq (rename-package (find-package "TB-FOO-3") "TB-FOO-4") package) + (eq (find-package "TB-FOO-4") package)))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '(#\a #\b)) + (let ((package (make-package #\a :use nil))) + (and (eq (rename-package #\a #\b) package) + (eq (find-package #\b) package) + (string= (package-name package) #\b)))) +(let ((name-list (list #\a 'b "TB-FOO-0" "TB-FOO-1" 'test-foo-2))) + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + name-list) + (let* ((old (pop name-list)) + (package (make-package old :use nil))) + (dolist (new name-list t) + (unless (eq (rename-package old new) package) + (return nil)) + (setq old new)))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO" "TB-FOO-RENAMED" + "TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1")) + (let* ((package (make-package "TB-FOO" + :use nil + :nicknames '("TB-FOO-NICKNAME-0" + "TB-FOO-NICKNAME-1")))) + (and (eq (rename-package "TB-FOO" "TB-FOO-RENAMED") package) + (eq (find-package "TB-FOO-RENAMED") package) + (null (set-difference (package-nicknames "TB-FOO-RENAMED") + '("TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1") + :test #'string=))))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" + "TB-FOO-3" "TB-FOO-4" "TB-FOO-5")) + (let* ((package (make-package "TB-FOO-0" + :use nil + :nicknames '("TB-FOO-1" "TB-FOO-2")))) + (and (eq (rename-package package "TB-FOO-3" '("TB-FOO-4" "TB-FOO-5")) + package) + (eq (find-package "TB-FOO-3") package) + (eq (find-package "TB-FOO-4") package) + (eq (find-package "TB-FOO-5") package) + (not (every #'find-package + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2")))))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2")) + (let* ((package (make-package "TB-FOO-0" :use nil :nicknames '("TB-FOO-1")))) + (eq (rename-package package "TB-FOO-1" '("TB-FOO-2")) package))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" + "TB-FOO-3" "TB-FOO-4" "TB-FOO-5")) + (let* ((package (make-package "TB-FOO-0" :use nil :nicknames '("TB-FOO-1")))) + (and (eq (rename-package package "TB-FOO-1" '("TB-FOO-2")) package) + (eq (rename-package package "TB-FOO-2" '("TB-FOO-3")) package) + (eq (rename-package package "TB-FOO-3" '("TB-FOO-4")) package) + (eq (rename-package package "TB-FOO-4" '("TB-FOO-5")) package) + (eq (rename-package package "TB-FOO-5" '("TB-FOO-0")) package) + (eq (find-package 'test-foo-5) (find-package 'test-foo-0))))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2")) + (let* ((package (make-package "TB-FOO-0" :use nil + :nicknames '("TB-FOO-1" "TB-FOO-2")))) + (and (eq (rename-package package "TB-FOO-2" '("TB-FOO-3" "TB-FOO-1")) + package) + (string= (package-name package) "TB-FOO-2") + (null (set-difference (package-nicknames package) + '("TB-FOO-3" "TB-FOO-1") + :test #'string=))))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2")) + (let* ((package (make-package "TB-FOO-0" :use nil + :nicknames '("TB-FOO-1" "TB-FOO-2")))) + (and (eq (rename-package package "TB-FOO-3") package) + (string= (package-name package) "TB-FOO-3") + (null (package-nicknames package))))) + + +;; find-symbol +(equal (multiple-value-list (find-symbol "CAR" "CL")) '(cl:car :EXTERNAL)) +(equal (multiple-value-list (find-symbol "CDR" "CL")) '(cl:cdr :EXTERNAL)) +(equal (multiple-value-list (find-symbol "CDR" 'cl)) '(cl:cdr :EXTERNAL)) +(equal (multiple-value-list (find-symbol "CDR" (find-package 'cl))) + '(cl:cdr :EXTERNAL)) +(equal (multiple-value-list (find-symbol "NIL" "CL")) '(nil :EXTERNAL)) +(let ((*package* (find-package 'cl))) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :EXTERNAL))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (equal (multiple-value-list (find-symbol "A" #\A)) '(nil nil))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (equal (multiple-value-list (find-symbol "A" "TB-FOO")) '(nil nil))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (multiple-value-bind (symbol0 status0) (intern "A" "TB-FOO") + (multiple-value-bind (symbol1 status1) (find-symbol "A" "TB-FOO") + (and (eq symbol0 symbol1) + (null status0) + (eq status1 :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use '("CL")) + (equal (multiple-value-list (find-symbol "CAR" "TB-FOO")) + '(cl:car :inherited))) +(do-external-symbols (symbol "CL" t) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol) "COMMON-LISP-USER") + (unless (and (eq symbol symbol-found) (eq status :inherited)) + (error "Symbol ~S is ~S" symbol-found status)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '("COMMON-LISP")))) + (and (equal (multiple-value-list (find-symbol "APPEND")) + '(cl:append :inherited)) + (equal (multiple-value-list (find-symbol "FIND")) + '(cl:find :inherited)) + (equal (multiple-value-list (find-symbol "CAR")) + '(cl:car :inherited))))) +(equal (multiple-value-list (find-symbol "NIL" 'cl)) '(nil :external)) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use (list 'cl))) + (symbol (intern "car" *package*))) + (and (equal (multiple-value-list (find-symbol "car")) + (list symbol :internal)) + (equal (multiple-value-list (find-symbol "CAR")) + (list 'cl:car :inherited))))) + + +;; find-all-symbols +(member 'cl:car (find-all-symbols 'car)) +(member 'cl:cdr (find-all-symbols "CDR")) +(every #'symbolp (find-all-symbols "LOOP")) +(every #'(lambda (name) (string= name "FIND")) + (mapcar #'symbol-name (find-all-symbols "FIND"))) +(dolist (name (list "CAR" "CDR" #\a #\A 'common-lisp 'join "" "XXX" "aA" + "LONGLONGLONGLONGLONGLONGLONGLONGLONGLONG" + 'long-long-long-long-long-long-name) t) + (unless (every #'(lambda (symbol-name) (string= symbol-name name)) + (mapcar #'symbol-name (find-all-symbols name))) + (return nil))) + + +;; intern +(symbolp (intern "SYMBOL")) +(symbolp (intern "long-long-name-in-lower-case")) +(equal (multiple-value-list (intern "NIL" 'cl)) '(nil :external)) +(multiple-value-bind (boo status) (intern "BOO") + (and (symbolp boo) + (member status '(nil :internal :external :inherited)) + (string= (symbol-name boo) "BOO"))) +(let ((*package* (find-package "CL"))) + (equal (multiple-value-list (intern "CAR")) '(cl:car :external))) +(let ((*package* (find-package "KEYWORD"))) + (equal (multiple-value-list (intern "TEST")) '(:test :external))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (multiple-value-list (intern "BOO" 'tb-foo)) + (list (find-symbol "BOO" 'tb-foo) nil) + (eq (symbol-package (find-symbol "BOO" 'tb-foo)) (find-package 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (eq (intern "CAR") 'cl:car) + (equal (multiple-value-list (intern "ZZZ")) + (list (find-symbol "ZZZ") nil)) + (equal (multiple-value-list (intern "ZZZ")) + (list (find-symbol "ZZZ") :internal)) + (export (find-symbol "ZZZ")) + (equal (multiple-value-list (intern "ZZZ")) + (list (find-symbol "ZZZ") :external))))) + +;; export +(eq (export ()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + buz) + (and (setq buz (intern "BUZ")) + (equal (multiple-value-list (find-symbol "BUZ")) (list buz :internal)) + (eq (export buz) t) + (equal (multiple-value-list (find-symbol "BUZ")) + (list buz :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (eq (export 'cl:car) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (eq (export '(cl:car)) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :inherited)) + (eq (export '(cl:car cl:cdr)) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl))) + (buz (make-symbol "BUZ"))) + (import buz) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :inherited)) + (equal (multiple-value-list (find-symbol "BUZ")) (list buz :internal)) + (eq (export (list 'cl:car buz 'cl:cdr)) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :external)) + (equal (multiple-value-list (find-symbol "BUZ")) + (list buz :external))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (import 'cl:car "A") + (and (eq (export 'cl:car "A") t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + '(cl:car :external)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (import 'cl:car "A") + (and (eq (export 'cl:car #\A) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + '(cl:car :external)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (import 'cl:car "A") + (and (eq (export 'cl:car 'a) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + '(cl:car :external)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (import 'cl:car "A") + (and (eq (export 'cl:car (find-package 'a)) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + '(cl:car :external)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (eq (export 'cl:car) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)) + (unuse-package 'cl) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (make-package "TB-FOO" :use '("TB-BAR-TO-USE")) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (export buz 'tb-bar-to-use) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz :inherited))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (MAKE-PACKAGE "TB-FOO" :USE NIL) + (EXPORT 'CAR "TB-FOO")) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL) + (MAKE-PACKAGE "TB-FOO" :USE '("TB-BAR-TO-USE")) + (INTERN "BUZ" 'TB-FOO) + (LET ((BUZ (INTERN "BUZ" 'TB-BAR-TO-USE))) + (EXPORT BUZ 'TB-BAR-TO-USE))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +;; unexport +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + buz) + (and (export (setq buz (intern "BUZ"))) + (equal (multiple-value-list (find-symbol "BUZ")) (list buz :external)) + (eq (unexport buz) t) + (equal (multiple-value-list (find-symbol "BUZ")) + (list buz :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'a)) 'a) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :external)) + (eq (unexport buz 'a) t) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'a)) 'a) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :external)) + (eq (unexport buz #\A) t) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'a)) 'a) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :external)) + (eq (unexport buz "A") t) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'a)) 'a) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :external)) + (eq (unexport buz (find-package "A")) t) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'tb-foo)) 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz :external)) + (eq (unexport buz 'tb-foo) t) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + (names '("A" "BC" "DEF" "GHIJ")) + (symbols (mapcar #'intern names))) + (and (export symbols) + (eq (unexport symbols) t) + (every #'(lambda (status) (eq status :internal)) + (mapcar #'(lambda (name) + (cadr (multiple-value-list (find-symbol name)))) + names))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil))) + (import '(cl:nil)) + (export '(cl:nil)) + (and (eq (unexport 'cl:nil) t) + (equal (multiple-value-list (find-symbol "NIL")) '(cl:nil :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil))) + (import '(cl:nil)) + (export '(cl:nil)) + (and (eq (unexport '(cl:nil)) t) + (equal (multiple-value-list (find-symbol "NIL")) '(nil :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + (baz (intern "BAZ" *package*))) + (and + (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal)) + (eq (unexport (list baz) *package*) t) + (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + (baz (intern "BAZ" *package*)) + (woo (intern "WOO" *package*))) + (export woo) + (and + (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal)) + (equal (multiple-value-list (find-symbol "WOO")) (list woo :external)) + (eq (unexport (list baz woo) *package*) t) + (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal)) + (equal (multiple-value-list (find-symbol "WOO")) (list woo :internal))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET* ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))) + (UNEXPORT 'CAR))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET* ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)) + (BAZ (INTERN "BAZ" *PACKAGE*)) + (WOO (INTERN "WOO" *PACKAGE*))) + (EXPORT WOO) + (UNEXPORT (LIST BAZ 'NIL WOO) *PACKAGE*))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + + +;; shadow +(eq (shadow '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow "A" 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(eq (shadow '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow #\A 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(eq (shadow '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow 'a 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow '(a) 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow '("A") 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow '(#\A) 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (eq (shadow "BUZ" #\A) t) + (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal) + (equal (package-shadowing-symbols 'a) + (list (find-symbol "BUZ" 'a))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (eq (shadow "BUZ" "A") t) + (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal) + (equal (package-shadowing-symbols 'a) + (list (find-symbol "BUZ" 'a))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (eq (shadow "BUZ" 'a) t) + (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal) + (equal (package-shadowing-symbols 'a) + (list (find-symbol "BUZ" 'a))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (eq (shadow "BUZ" (find-package 'a)) t) + (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal) + (equal (package-shadowing-symbols 'a) + (list (find-symbol "BUZ" 'a))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (names '(a #\B "C" "BUZ"))) + (and (eq (shadow names) t) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name))) + :internal)) + names) + (null (set-difference (mapcar #'find-symbol (mapcar #'string names)) + (package-shadowing-symbols *package*)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl))) + (names '(a #\B "C" "BUZ" "CAR")) + a b c) + (setq a (intern "A")) + (export (setq b (intern "B"))) + (shadowing-import (setq c (intern "C"))) + (and (eq (shadow names) t) + (equal (multiple-value-list (find-symbol "A")) (list a :internal)) + (equal (multiple-value-list (find-symbol "B")) (list b :external)) + (equal (multiple-value-list (find-symbol "C")) (list c :internal)) + (eq (cadr (multiple-value-list (find-symbol "BUZ"))) :internal) + (eq (cadr (multiple-value-list (find-symbol "CAR"))) :internal) + (not (eq (car (multiple-value-list (find-symbol "CAR"))) 'cl:car)) + (null (set-difference (mapcar #'find-symbol (mapcar #'string names)) + (package-shadowing-symbols *package*)))))) + + + + +;; shadowing-import +(eq (shadowing-import '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (shadowing-import '() (make-package "TB-FOO" :use nil)) + (let ((list nil)) + (null (do-symbols (symbol "TB-FOO" list) (push symbol list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (not (find-symbol "CDR")) + (not (find-symbol "LIST")) + (eq (shadowing-import '(cl:car cl:cdr cl:list)) t) + (eq (find-symbol "CAR") 'cl:car) + (eq (find-symbol "CDR") 'cl:cdr) + (eq (find-symbol "LIST") 'cl:list)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use (list 'cl))) + (names '("CAR" "CDR" "LIST" "APPEND")) + (symbols (mapcar #'make-symbol names))) + (and (eq (shadowing-import symbols) t) + (every #'eq symbols (mapcar #'find-symbol names)) + (every #'(lambda (symbol) + (member symbol (package-shadowing-symbols *package*))) + symbols)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((symbol (make-symbol "CAR"))) + (and (eq (shadowing-import symbol "A") t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + (list symbol :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((symbol (make-symbol "CAR"))) + (and (eq (shadowing-import symbol #\A) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + (list symbol :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((symbol (make-symbol "CAR"))) + (and (eq (shadowing-import symbol 'a) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + (list symbol :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((symbol (make-symbol "CAR"))) + (and (eq (shadowing-import symbol (find-package 'a)) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + (list symbol :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz0 (intern "BUZ" 'tb-foo)) + (buz1 (make-symbol "BUZ"))) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz0 :internal)) + (eq (shadowing-import buz1 'tb-foo) t) + + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz1 :internal)) + (equal (list buz1) (package-shadowing-symbols 'tb-foo)) + (unintern buz1 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (null (package-shadowing-symbols 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz0 (intern "BUZ" 'tb-foo)) + (buz1 (make-symbol "BUZ"))) + (shadow buz0 'tb-foo) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz0 :internal)) + (eq (shadowing-import buz1 'tb-foo) t) + + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz1 :internal)) + (equal (list buz1) (package-shadowing-symbols 'tb-foo)) + (unintern buz1 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (null (package-shadowing-symbols 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz0 (intern "BUZ" 'tb-foo)) + (buz1 (make-symbol "BUZ"))) + (export buz0 'tb-foo) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz0 :external)) + (eq (shadowing-import buz1 'tb-foo) t) + + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz1 :internal)) + (equal (list buz1) (package-shadowing-symbols 'tb-foo)) + (unintern buz1 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (null (package-shadowing-symbols 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz0 (intern "BUZ" 'tb-foo)) + (buz1 (make-symbol "BUZ"))) + (export buz0 'tb-foo) + (shadow buz0 'tb-foo) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz0 :external)) + (eq (shadowing-import buz1 'tb-foo) t) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz1 :internal)) + (equal (list buz1) (package-shadowing-symbols 'tb-foo)) + (unintern buz1 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (null (package-shadowing-symbols 'tb-foo))))) + + + +;; import +(eq (import '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((list nil)) + (and (eq (import '() "TB-FOO") t) + (null (do-symbols (symbol "TB-FOO" list) (push symbol list)))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (not (find-symbol "CAR" 'a)) + (eq (import 'cl:car 'a) t) + (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (not (find-symbol "CAR" 'a)) + (eq (import 'cl:car #\A) t) + (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (not (find-symbol "CAR" 'a)) + (eq (import 'cl:car "A") t) + (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (not (find-symbol "CAR" 'a)) + (eq (import 'cl:car (find-package "A")) t) + (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (not (find-symbol "CAR" 'tb-foo)) + (eq (import 'cl:car 'tb-foo) t) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo)) + '(cl:car :internal)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (not (find-symbol "CAR" 'tb-foo)) + (eq (import (list 'cl:car 'cl:cdr 'cl:list :test) 'tb-foo) t) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo)) + '(cl:car :internal)) + (equal (multiple-value-list (find-symbol "CDR" 'tb-foo)) + '(cl:cdr :internal)) + (equal (multiple-value-list (find-symbol "TEST" 'tb-foo)) + '(:test :internal)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR" 'tb-foo)) + (eq (import (list 'cl:car 'cl:cdr 'cl:list :test)) t) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo)) + '(cl:car :internal)) + (equal (multiple-value-list (find-symbol "CDR" 'tb-foo)) + '(cl:cdr :internal)) + (equal (multiple-value-list (find-symbol "TEST" 'tb-foo)) + '(:test :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let (buz) + (make-package "TB-FOO" :use nil) + (and (export (setq buz (intern "BUZ" "TB-FOO")) "TB-FOO") + (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO")) + (list buz :external)) + (eq (import buz "TB-FOO") t) + (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO")) + (list buz :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let (buz) + (make-package "TB-FOO" :use nil) + (and (setq buz (intern "BUZ" "TB-FOO")) + (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO")) + (list buz :internal)) + (eq (import buz "TB-FOO") t) + (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO")) + (list buz :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (eq (import 'cl:car) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz (make-symbol "BUZ"))) + (and (null (symbol-package buz)) + (eq (import buz 'tb-foo) t) + (eq (symbol-package buz) (find-package 'tb-foo))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE '(CL)))) + (IMPORT (MAKE-SYMBOL "CAR")))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))) + (INTERN "BUZ") + (IMPORT (MAKE-SYMBOL "BUZ")))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))) + (EXPORT (INTERN "BUZ")) + (IMPORT (MAKE-SYMBOL "BUZ")))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))) + (SHADOWING-IMPORT (MAKE-SYMBOL "BUZ")) + (IMPORT (MAKE-SYMBOL "BUZ")))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +;; unintern +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (not (unintern 'cl:car "TB-FOO"))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (unintern (intern "BUZ" "TB-FOO") "TB-FOO") + (not (find-symbol "BUZ" "TB-FOO")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (not (unintern 'cl:car)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (unintern (intern "BUZ")) + (not (find-symbol "BUZ"))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (unintern (intern "BUZ" "A") #\A) + (not (find-symbol "BUZ" "A")))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (unintern (intern "BUZ" "A") "A") + (not (find-symbol "BUZ" "A")))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (unintern (intern "BUZ" "A") 'a) + (not (find-symbol "BUZ" "A")))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (unintern (intern "BUZ" "A") (find-package 'a)) + (not (find-symbol "BUZ" "A")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (not (unintern 'cl:car))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (import 'cl:car) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal)) + (unintern 'cl:car) + (not (find-symbol "CAR"))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (import 'cl:car) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal)) + (unintern 'cl:car) + (equal (multiple-value-list (find-symbol "CAR")) + '(cl:car :inherited))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (buz (make-symbol "BUZ"))) + (and (null (symbol-package buz)) + (import buz) + (shadow buz) + (eq (symbol-package buz) *package*) + (member buz (package-shadowing-symbols *package*)) + (unintern buz) + (not (find-symbol "BUZ")) + (not (member buz (package-shadowing-symbols *package*))) + (null (symbol-package buz))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)) SYMBOL) + (AND (SETQ SYMBOL (INTERN "CAR")) + (SHADOW "CAR") + (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL) + (EXPORT (INTERN "CAR" "TB-BAR-TO-USE") "TB-BAR-TO-USE") + (USE-PACKAGE (LIST "TB-BAR-TO-USE" "CL")) + (EQUAL (MULTIPLE-VALUE-LIST (FIND-SYMBOL "CAR")) + (LIST SYMBOL :INTERNAL)) + (UNINTERN SYMBOL)))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (let ((*package* (make-package "TB-FOO" :use nil)) + symbol) + (and (setq symbol (intern "CAR")) + (shadow "CAR") + (make-package "TB-BAR-TO-USE" :use nil) + (import 'cl:car "TB-BAR-TO-USE") + (export 'cl:car "TB-BAR-TO-USE") + (use-package (list "TB-BAR-TO-USE" "CL")) + (equal (multiple-value-list (find-symbol "CAR")) + (list symbol :internal)) + (unintern symbol)))) + + + +;; use-package +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package 'cl) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package "COMMON-LISP") t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package (find-package "COMMON-LISP")) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package '(cl)) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package '("COMMON-LISP")) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package (list (find-package "COMMON-LISP"))) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + (*package* (find-package 'cl-user))) + (and (not (find-symbol "CAR" package)) + (eq (use-package (list (find-package "COMMON-LISP")) package) t) + (find-symbol "CAR" package)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + (*package* (find-package 'cl-user))) + (and (not (find-symbol "CAR" package)) + (eq (use-package (list (find-package "COMMON-LISP")) "TB-FOO") t) + (find-symbol "CAR" package)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + (*package* (find-package 'cl-user))) + (and (not (find-symbol "CAR" package)) + (eq (use-package (list (find-package "COMMON-LISP")) 'tb-foo) t) + (find-symbol "CAR" package)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + (*package* (find-package 'cl-user))) + (and (not (find-symbol "CAR" package)) + (eq (use-package (list (find-package "COMMON-LISP")) + (find-package 'tb-foo)) + t) + (find-symbol "CAR" package)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (use-package 'cl) + (member (find-package 'cl) (package-use-list *package*))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + boo woo buz) + (and (make-package "TB-BAR-TO-USE" :use nil) + (export (list (setq boo (intern "BOO" 'tb-bar-to-use))) 'tb-bar-to-use) + (setq woo (intern "WOO")) + (export (list (setq buz (intern "BUZ")))) + (use-package (list 'tb-bar-to-use 'cl)) + (equal (multiple-value-list (find-symbol "BOO")) (list boo :inherited)) + (equal (multiple-value-list (find-symbol "WOO")) (list woo :internal)) + (equal (multiple-value-list (find-symbol "BUZ")) (list buz :external)) + (equal (multiple-value-list (find-symbol "CAR")) + (list 'cl:car :inherited)) + (equal (multiple-value-list (find-symbol "LIST")) + (list 'cl:list :inherited))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (MAKE-PACKAGE "TB-FOO" :USE NIL) + (INTERN "CAR" 'TB-FOO) + (USE-PACKAGE 'CL 'TB-FOO)) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (MAKE-PACKAGE "TB-FOO" :USE NIL) + (EXPORT (INTERN "CAR" 'TB-FOO) 'TB-FOO) + (USE-PACKAGE 'CL 'TB-FOO)) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (MAKE-PACKAGE "TB-FOO" :USE '(CL)) + (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL) + (EXPORT (INTERN "CAR" 'TB-BAR-TO-USE) 'TB-BAR-TO-USE) + (USE-PACKAGE 'TB-BAR-TO-USE 'TB-FOO)) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +;; unuse-package +(progn + (when (find-package "TB-FOO-TO-USE") + (unuse-package (package-use-list "TB-FOO-TO-USE") "TB-FOO-TO-USE")) + (when (find-package "TB-BAR-TO-USE") + (unuse-package (package-use-list "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + (when (find-package "TB-FOO-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-FOO-TO-USE")) + (delete-package "TB-FOO-TO-USE")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (and (make-package "TB-FOO-TO-USE" :use nil) + (make-package "TB-BAR-TO-USE" :use '("TB-FOO-TO-USE")) + (use-package "TB-BAR-TO-USE" "TB-FOO-TO-USE") + (export (intern "FOO" "TB-FOO-TO-USE") "TB-FOO-TO-USE") + (export (intern "BAR" "TB-BAR-TO-USE") "TB-BAR-TO-USE") + (eq (cadr (multiple-value-list (find-symbol "FOO" "TB-FOO-TO-USE"))) + :external) + (eq (cadr (multiple-value-list (find-symbol "BAR" "TB-FOO-TO-USE"))) + :inherited) + (eq (cadr (multiple-value-list (find-symbol "FOO" "TB-BAR-TO-USE"))) + :inherited) + (eq (cadr (multiple-value-list (find-symbol "BAR" "TB-BAR-TO-USE"))) + :external) + (unuse-package (package-use-list "TB-FOO-TO-USE") "TB-FOO-TO-USE") + (unuse-package (package-use-list "TB-BAR-TO-USE") "TB-BAR-TO-USE"))) + + +;; delete-package +(progn + (when (find-package "a") (delete-package "a")) + (and (make-package "a" :use nil) + (delete-package "a") + (not (find-package "a")))) +(progn + (when (find-package "a") (delete-package "a")) + (and (make-package "a" :use nil) + (delete-package #\a) + (not (find-package "a")))) +(progn + (when (find-package "a") (delete-package "a")) + (and (make-package "a" :use nil) + (delete-package '|a|) + (not (find-package "a")))) +(progn + (when (find-package "a") (delete-package "a")) + (and (make-package "a" :use nil) + (delete-package (find-package '|a|)) + (not (find-package "a")))) +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("a" "b" "c" "d" "e")) + (and (make-package "a" :nicknames '("b" "c" "d" "e") :use nil) + (delete-package "a") + (not (find-package "a")) + (not (find-package "b")) + (not (find-package "c")) + (not (find-package "d")) + (not (find-package "e")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil))) + (and (delete-package "TB-FOO") + (not (find-package "TB-FOO")) + (packagep package) + (null (package-name package))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil))) + (and (delete-package "TB-FOO") + (not (member package (list-all-packages)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil))) + (and (delete-package "TB-FOO") + (null (delete-package package))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((car-home-package (symbol-package 'cl:car))) + (and (make-package "TB-FOO" :use nil) + (import 'cl:car "TB-FOO") + (delete-package 'tb-foo) + (eq 'cl:car (find-symbol "CAR" 'cl)) + (eq (symbol-package 'cl:car) car-home-package) + (eq (intern "CAR" 'cl) 'cl:car)))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (AND (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL) + (MAKE-PACKAGE "TB-FOO" :USE '("TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE"))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +;; in-package +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (in-package cl-user) + (eq *package* (find-package 'cl-user)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (in-package "CL-USER") + (eq *package* (find-package 'cl-user)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((*package* *package*)) + (in-package "A") + (eq *package* (find-package 'a)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((*package* *package*)) + (in-package #\A) + (eq *package* (find-package 'a)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((*package* *package*)) + (in-package a) + (eq *package* (find-package 'a)))) +(progn + (when (find-package "A") (delete-package "A")) + (HANDLER-CASE (PROGN (IN-PACKAGE "A")) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))) + + +;; defpackage +(progn + (when (find-package "A") (delete-package "A")) + (packagep (defpackage #\A))) +(progn + (when (find-package "A") (delete-package "A")) + (packagep (defpackage a))) +(progn + (when (find-package "A") (delete-package "A")) + (packagep (defpackage "A"))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO")) + (null (package-nicknames 'tb-foo)) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:nicknames))) + (null (package-nicknames 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:nicknames) (:shadow))) + (null (package-nicknames 'tb-foo)) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:nicknames) + (:shadow) + (:shadowing-import-from common-lisp))) + (null (package-nicknames 'tb-foo)) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3")) + (and (packagep (defpackage "TB-FOO" (:nicknames tb-foo-nickname-1))) + (equal (package-nicknames 'tb-foo) '("TB-FOO-NICKNAME-1")))) +#-CLISP +;; Bruno: unfounded assumptions about the order of the package-nicknames list +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3")) + (and (packagep (defpackage "TB-FOO" + (:nicknames tb-foo-nickname-1 tb-foo-nickname-2 + tb-foo-nickname-3))) + (equal (package-nicknames 'tb-foo) + '("TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3")))) +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("A" "B" "C" "D")) + (and (packagep (defpackage "A" (:nicknames #\B c "D"))) + (null (set-difference (package-nicknames 'a) '("B" "C" "D") + :test #'string=)))) +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("A" "B" "C" "D")) + (and (packagep (defpackage "A" + (:nicknames) (:nicknames #\B) (:nicknames c "D"))) + (null (set-difference (package-nicknames 'a) '("B" "C" "D") + :test #'string=)))) +;(progn +; (when (find-package "TB-FOO") (delete-package "TB-FOO")) +; (and (packagep (defpackage "TB-FOO" +; (:nicknames) (:documentation "doc for tb-foo package"))) +; (packagep (find-package 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:use))) + (null (package-use-list 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:use cl))) + (equal (package-use-list 'tb-foo) (list (find-package 'cl))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl tb-bar-to-use))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl tb-bar-to-use)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use tb-bar-to-use))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl tb-bar-to-use)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use "TB-BAR-TO-USE"))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl tb-bar-to-use)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "B") + (mapcan #'delete-package (package-used-by-list "B")) + (delete-package "B")) + (make-package "B" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use "B"))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl b)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "B") + (mapcan #'delete-package (package-used-by-list "B")) + (delete-package "B")) + (make-package "B" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use #\B))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl b)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "B") + (mapcan #'delete-package (package-used-by-list "B")) + (delete-package "B")) + (make-package "B" :use nil) + (and (packagep (eval `(defpackage "TB-FOO" + (:use cl) (:use) (:use ,(find-package #\B))))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl b)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadow))) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadow "A"))) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadow a #\b "c" "D"))) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (mapcar #'(lambda (name) (find-symbol name 'tb-foo)) + '("A" "b" "c" "D")))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadow a) (:shadow ) + (:shadow #\b "c" "D")))) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (mapcar #'(lambda (name) (find-symbol name 'tb-foo)) + '("A" "b" "c" "D"))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadowing-import-from cl))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadowing-import-from "COMMON-LISP"))) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:shadowing-import-from "COMMON-LISP" car cdr list))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR" "LIST")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + '(cl:car cl:cdr cl:list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:shadowing-import-from "COMMON-LISP" car cdr) + (:shadowing-import-from "COMMON-LISP") + (:shadowing-import-from "COMMON-LISP" list))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR" "LIST")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + '(cl:car cl:cdr cl:list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:shadowing-import-from "COMMON-LISP" car cdr) + (:shadowing-import-from tb-bar-to-use "BUZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (list 'cl:car 'cl:cdr buz)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use)) + (baz (intern "BAZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:shadowing-import-from "COMMON-LISP" car cdr) + (:shadowing-import-from tb-bar-to-use "BUZ" "BAZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "BUZ" "BAZ")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (list 'cl:car 'cl:cdr buz baz)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use)) + (baz (intern "BAZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:shadow "BOO") + (:shadowing-import-from "COMMON-LISP" car cdr) + (:shadowing-import-from tb-bar-to-use "BUZ" "BAZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "BUZ" "BAZ" "BOO")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (list 'cl:car 'cl:cdr buz baz + (find-symbol "BOO" 'tb-foo))))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (eval `(defpackage "TB-FOO" + (:shadowing-import-from ,(find-package 'cl) + "CAR" "CDR")))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (eval `(defpackage "TB-FOO" + (:import-from ,(find-package 'cl) + "CAR" "CDR")))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:import-from cl)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:import-from cl "CAR" "CDR"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:import-from "COMMON-LISP" car cdr list))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "LIST")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:import-from "COMMON-LISP" car cdr) + (:import-from "COMMON-LISP") + (:import-from "COMMON-LISP" list))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "LIST")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:import-from "COMMON-LISP" car cdr) + (:import-from tb-bar-to-use "BUZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")) + (eq (find-symbol "BUZ" 'tb-foo) buz)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use)) + (baz (intern "BAZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:import-from "COMMON-LISP" car cdr) + (:import-from tb-bar-to-use "BUZ" "BAZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "BUZ" "BAZ")) + (eq (find-symbol "BUZ" 'tb-foo) buz) + (eq (find-symbol "BAZ" 'tb-foo) baz)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:export)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:export) (:export)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:export "A"))) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :external))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:export "A" "B" "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:export "A" "B" "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:export "A") (:export "B") (:export "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:export "A" "B" "C" "CAR") + (:use cl))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C" "CAR")) + (eq (find-symbol "CAR" 'tb-foo) 'cl:car))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:export "A" "B" "C" "CAR") + (:import-from cl "CAR"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C" "CAR")) + (eq (find-symbol "CAR" 'tb-foo) 'cl:car))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:export "A" "B" "C" "CAR") + (:shadowing-import-from cl "CAR"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C" "CAR")) + (eq (find-symbol "CAR" 'tb-foo) 'cl:car))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:export "A" "B" "C" "CAR" "CDR" "BUZ") + (:use tb-bar-to-use) + (:import-from cl "CDR") + (:shadowing-import-from cl "CAR"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C" "CAR" "CDR" "BUZ")) + (eq (find-symbol "CAR" 'tb-foo) 'cl:car) + (eq (find-symbol "CDR" 'tb-foo) 'cl:cdr) + (eq (find-symbol "BUZ" 'tb-bar-to-use) buz)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:intern)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:intern) (:intern)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:intern "A"))) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:intern "A" "B" "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :internal)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:intern "A" "B" "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :internal)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:intern "A") (:intern "B") (:intern "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :internal)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:intern "A" "B" "C" "CAR") + (:use cl))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :internal)) + '("A" "B" "C")) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo)) + '(cl:car :inherited)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:size 10))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:size 0))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:size 1000))))) + +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (export buz 'tb-bar-to-use) + (and + (packagep + (defpackage "TB-FOO" + (:size 10) + (:shadow "SHADOW1" "SHADOW2") + (:shadowing-import-from cl "CAR" "CDR") + (:use tb-bar-to-use) + (:import-from keyword "TEST") + (:intern "S0" "S1") + ;;(:documentation "doc") + (:nicknames "TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2") + (:export "SHADOW1" "CAR"))) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo-nickname-0)) + (list buz :inherited)) + (eq (cadr (multiple-value-list (find-symbol "SHADOW1" 'tb-foo-nickname-2))) + :external) + (eq (cadr (multiple-value-list (find-symbol "SHADOW2" 'tb-foo-nickname-2))) + :internal) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo-nickname-2)) + (list 'cl:car :external)) + (equal (multiple-value-list (find-symbol "CDR" 'tb-foo-nickname-2)) + (list 'cl:cdr :internal)) + (equal (multiple-value-list (find-symbol "TEST" 'tb-foo-nickname-2)) + (list :test :internal)) + (eq (cadr (multiple-value-list (find-symbol "S0" 'tb-foo-nickname-2))) + :internal) + (eq (cadr (multiple-value-list (find-symbol "S1" 'tb-foo-nickname-2))) + :internal) + ))) + +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (export buz 'tb-bar-to-use) + (and + (packagep + (defpackage "TB-FOO" + (:export "SHADOW1") + (:size 10) + (:nicknames "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2") + (:shadow "SHADOW1") + (:shadowing-import-from cl "CAR") + (:intern "S1") + (:shadowing-import-from cl) + (:use tb-bar-to-use) + (:nicknames "TB-FOO-NICKNAME-0") + (:shadowing-import-from cl "CDR") + (:shadow "SHADOW2") + (:import-from keyword "TEST") + (:intern "S0") + ;;(:documentation "doc") + (:nicknames) + (:export "CAR"))) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo-nickname-0)) + (list buz :inherited)) + (eq (cadr (multiple-value-list (find-symbol "SHADOW1" 'tb-foo-nickname-2))) + :external) + (eq (cadr (multiple-value-list (find-symbol "SHADOW2" 'tb-foo-nickname-2))) + :internal) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo-nickname-2)) + (list 'cl:car :external)) + (equal (multiple-value-list (find-symbol "CDR" 'tb-foo-nickname-2)) + (list 'cl:cdr :internal)) + (equal (multiple-value-list (find-symbol "TEST" 'tb-foo-nickname-2)) + (list :test :internal)) + (eq (cadr (multiple-value-list (find-symbol "S0" 'tb-foo-nickname-2))) + :internal) + (eq (cadr (multiple-value-list (find-symbol "S1" 'tb-foo-nickname-2))) + :internal) + ))) + + + + + +;; with-package-iterator +(with-package-iterator (get "CL" :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get 'cl :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get (find-package 'cl) :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get '(cl) :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get (list "CL") :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get (list (find-package "COMMON-LISP")) :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get 'cl :external :internal :inherited) + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore more)) + (and (symbolp symbol) + (member status '(:external :internal :inherited)) + (eq pkg (find-package 'cl))))) + +(with-package-iterator (get (list 'cl) :internal) + (multiple-value-bind (more symbol status pkg) (get) + (or (not more) + (and (symbolp symbol) + (eq status :internal) + (eq pkg (find-package 'cl)))))) + +(with-package-iterator (get (list 'cl) :inherited) + (multiple-value-bind (more symbol status pkg) (get) + (or (not more) + (and (symbolp symbol) + (eq status :inherited) + (eq pkg (find-package 'cl)))))) + +;;; cmucl barfs on (macrolet () (declare)) +(progn + #-cmu + (with-package-iterator (get "CL" :external) + (declare (optimize (safety 3))) + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + #+cmu 'skipped) +(progn + (when (find-package "TB-FOO") + (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + list) + (with-package-iterator (get package :internal) + (and (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore status pkg)) + (unless more (return t)) + (push symbol list))) + (null list))))) +(progn + (when (find-package "TB-FOO") + (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil))) + (dolist (name '(a b c d e f g "S1" "S2" "ss")) + (intern name package)) + (with-package-iterator (get package :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (unless more (return t)) + (unless (and (eq status :internal) + (eq pkg package) + (eq symbol (find-symbol (string symbol) pkg))) + (return nil))))))) +(progn + (when (find-package #\a) + (delete-package #\a)) + (let ((package (make-package #\a :use nil))) + (dolist (name '(a b c d e f g "S1" "S2" "ss")) + (intern name package)) + (with-package-iterator (get #\a :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (unless more (return t)) + (unless (and (eq status :internal) + (eq pkg package) + (eq symbol (find-symbol (string symbol) pkg))) + (return nil))))))) +(progn + (when (find-package #\a) + (delete-package #\a)) + (let ((package (make-package #\a :use nil))) + (dolist (name '(a b c d e f g "S1" "S2" "ss")) + (intern name package)) + (with-package-iterator (get (list #\a) :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (unless more (return t)) + (unless (and (eq status :internal) + (eq pkg package) + (eq symbol (find-symbol (string symbol) pkg))) + (return nil))))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (let* ((package (make-package "TB-BAR-TO-USE" :use nil)) + (package-1 (make-package "TB-FOO" :use (list package))) + (symbol-list nil)) + (export (intern "S" package) package) + (shadow '("S") package-1) + (with-package-iterator (get package-1 :internal :external :inherited) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore status pkg)) + (unless more (return t)) + (push symbol symbol-list)))) + (not (member (intern "S" package) symbol-list)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((package (make-package "TB-FOO" :use nil)) + (symbol-list nil)) + (with-package-iterator (get package :internal :external) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore status pkg)) + (unless more (return t)) + (push symbol symbol-list)))) + (null symbol-list))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((package (make-package "TB-FOO" :use nil)) + (symbol-list '(a b c d car cdr i lisp)) + (list nil)) + (dolist (symbol symbol-list) + (shadowing-import symbol package)) + (with-package-iterator (get package :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore status pkg)) + (unless more (return t)) + (push symbol list)))) + (null (set-difference symbol-list list)))) +(with-package-iterator (get 'cl :external) + (loop + (multiple-value-bind (more symbol status package) (get) + (unless more (return t)) + (unless (and (eq status :external) + (eq package (find-package 'cl)) + (eq symbol (find-symbol (symbol-name symbol) 'cl-user))) + (return nil))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((package (make-package "TB-FOO" :use 'cl))) + (shadow '("CAR") package) + (with-package-iterator (get package :external :inherited :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore pkg status)) + (unless more (return t)) + (when (eq symbol 'cl:car) (return nil))))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + (names '("BLACK" "RED" "WHITE" "YELLOW" "VIOLET" "BROWN" "BLUE")) + list) + (mapc #'intern names) + (export (mapcar #'find-symbol + (mapcan #'(lambda (name) + (when (= (length name) 5) (list name))) names))) + (with-package-iterator (get *package* :external :inherited :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore pkg)) + (unless more (return)) + (push (symbol-name symbol) (getf list status))))) + (and (null (set-difference (getf list :external) '("BLACK" "WHITE" "BROWN") + :test #'string=)) + (null (set-difference (getf list :internal) + '("RED" "YELLOW" "VIOLET" "BLUE") + :test #'string=)) + (null (getf list :inherited))))) + + +(flet ((test-package-iterator (package) + (unless (packagep package) + (setq package (find-package package))) + (let ((all-entries '()) + (generated-entries '())) + (do-symbols (x package) + (multiple-value-bind (symbol accessibility) + (find-symbol (symbol-name x) package) + (push (list symbol accessibility) all-entries))) + (with-package-iterator (generator-fn package + :internal :external :inherited) + (loop + (multiple-value-bind (more? symbol accessibility pkg) + (generator-fn) + (declare (ignore pkg)) + (unless more? (return)) + (let ((l (multiple-value-list (find-symbol (symbol-name symbol) + package)))) + (unless (equal l (list symbol accessibility)) + (error "Symbol ~S not found as ~S in package ~A [~S]" + symbol accessibility (package-name package) l)) + (push l generated-entries))))) + (unless (and (subsetp all-entries generated-entries :test #'equal) + (subsetp generated-entries all-entries :test #'equal)) + (error "Generated entries and Do-Symbols entries don't correspond")) + t))) + (every #'test-package-iterator '("CL" "CL-USER" "KEYWORD"))) + + +;; do-symbols +(null (do-symbols (symbol) (declare (ignore symbol)))) +(null (do-symbols (symbol *package*) (declare (ignore symbol)))) +(null (do-external-symbols (symbol) (declare (ignore symbol)))) +(null (do-external-symbols (symbol *package*) (declare (ignore symbol)))) +(null (do-all-symbols (symbol) (declare (ignore symbol)))) +(do-symbols (symbol *package* (null symbol))) +(do-external-symbols (symbol *package* (null symbol))) +(do-all-symbols (symbol (null symbol))) +(do-symbols (symbol 'CL nil) (declare (ignore symbol)) (return t)) +(do-external-symbols (symbol 'CL nil) (declare (ignore symbol)) (return t)) +(do-all-symbols (symbol nil) (declare (ignore symbol)) (return t)) +(do-symbols (symbol 'cl nil) + (go start) + found + (return t) + start + (when (eq symbol 'cl:car) + (go found))) +(do-external-symbols (symbol 'cl nil) + (go start) + found + (return t) + start + (when (eq symbol 'cl:car) + (go found))) +(do-all-symbols (symbol nil) + (go start) + found + (return t) + start + (when (eq symbol 'cl:car) + (go found))) +(let ((i 0) + (list nil) + (*package* (find-package "COMMON-LISP-USER"))) + (do-symbols (symbol) + (push symbol list) + (incf i) + (when (= i 10) (return))) + (every #'symbolp list)) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf")) + (list)) + (export (mapcar #'intern name-list)) + (null (set-difference (do-symbols (symbol *package* list) + (pushnew symbol list)) + (mapcar #'find-symbol name-list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + list) + (do-symbols (symbol *package*) (push symbol list)) + (null list))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + list) + (do-symbols (symbol) (push symbol list)) + (null list))) +(do-symbols (symbol 'cl t) + (unless (eq symbol (find-symbol (symbol-name symbol) 'cl)) + (return nil))) +(do-symbols (symbol 'keyword t) + (unless (equal + (multiple-value-list (find-symbol (symbol-name symbol) 'keyword)) + (list symbol :external)) + (return nil))) + + +;; do-external-symbols +(let (list1 list2) + (and (do-external-symbols (symbol 'keyword t) (push symbol list1)) + (do-symbols (symbol 'keyword t) (push symbol list2)) + (null (set-difference list1 list2)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + list) + (do-external-symbols (symbol *package*) (push symbol list)) + (null list))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + list) + (do-external-symbols (symbol) (push symbol list)) + (null list))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf")) + (list)) + (export (mapcar #'intern name-list)) + (null (set-difference (do-external-symbols (symbol *package* list) + (pushnew symbol list)) + (mapcar #'find-symbol name-list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf")) + (list)) + (mapcar #'intern name-list) + (null (do-external-symbols (symbol *package* list) + (pushnew symbol list))))) + + +;; do-all-symbols +(let ((i 0) + (list nil)) + (do-all-symbols (symbol) + (push symbol list) + (incf i) + (when (= i 10) (return))) + (every #'symbolp list)) +(let ((list nil)) + (do-all-symbols (symbol) (push symbol list)) + (with-package-iterator (get (list-all-packages) :external :internal) + (loop + (multiple-value-bind (more symbol status package) (get) + (declare (ignore status package)) + (unless more (return t)) + (unless (member symbol list) (return nil)))))) + |