;; Copyright (C) 2002-2004, Yuji Minejima ;; 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))))))