X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpackages.impure.lisp;h=fbe8e5b6d8033800715d6e6e54cd4579abe1abb0;hb=8a19ff566e3a1a43cb3b2d11d2781a1c89981f43;hp=0e782181ebe30e68e43786e07feae83da3b20fb1;hpb=69990bc42314706e9d646ddd8f6b911f46d0052c;p=sbcl.git diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index 0e78218..fbe8e5b 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -304,3 +304,350 @@ if a restart was invoked." (with-timeout 10 (assert (eq 'cons (read-from-string "CL:CONS")))) (sb-thread:signal-semaphore sem2))) + +(with-test (:name :quick-name-conflict-resolution-import) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2")) + (intern "FOO" p1) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::dont-import-it)))) + (import (intern "FOO" p2) p1)) + (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::shadowing-import-it)))) + (import (intern "FOO" p2) p1)) + (assert (eq (intern "FOO" p1) (intern "FOO" p2)))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :quick-name-conflict-resolution-export.1) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a")) + (intern "FOO" p1) + (use-package p2 p1) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::keep-old)))) + (export (intern "FOO" p2) p2)) + (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :quick-name-conflict-resolution-export.2) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b")) + (intern "FOO" p1) + (use-package p2 p1) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::take-new)))) + (export (intern "FOO" p2) p2)) + (assert (eq (intern "FOO" p1) (intern "FOO" p2)))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :quick-name-conflict-resolution-use-package.1) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a")) + (intern "FOO" p1) + (intern "BAR" p1) + (export (intern "FOO" p2) p2) + (export (intern "BAR" p2) p2) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::keep-old)))) + (use-package p2 p1)) + (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))) + (assert (not (eq (intern "BAR" p1) (intern "BAR" p2))))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :quick-name-conflict-resolution-use-package.2) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b")) + (intern "FOO" p1) + (intern "BAR" p1) + (export (intern "FOO" p2) p2) + (export (intern "BAR" p2) p2) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::take-new)))) + (use-package p2 p1)) + (assert (eq (intern "FOO" p1) (intern "FOO" p2))) + (assert (eq (intern "BAR" p1) (intern "BAR" p2)))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name (:package-at-variance-restarts :shadow)) + (let ((p nil) + (*on-package-variance* '(:error t))) + (unwind-protect + (progn + (setf p (eval `(defpackage :package-at-variance-restarts.1 + (:use :cl) + (:shadow "CONS")))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::keep-them)))) + (eval `(defpackage :package-at-variance-restarts.1 + (:use :cl)))) + (assert (not (eq 'cl:cons (intern "CONS" p)))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::drop-them)))) + (eval `(defpackage :package-at-variance-restarts.1 + (:use :cl)))) + (assert (eq 'cl:cons (intern "CONS" p)))) + (when p (delete-package p))))) + +(with-test (:name (:package-at-variance-restarts :use)) + (let ((p nil) + (*on-package-variance* '(:error t))) + (unwind-protect + (progn + (setf p (eval `(defpackage :package-at-variance-restarts.2 + (:use :cl)))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::keep-them)))) + (eval `(defpackage :package-at-variance-restarts.2 + (:use)))) + (assert (eq 'cl:cons (intern "CONS" p))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::drop-them)))) + (eval `(defpackage :package-at-variance-restarts.2 + (:use)))) + (assert (not (eq 'cl:cons (intern "CONS" p))))) + (when p (delete-package p))))) + +(with-test (:name (:package-at-variance-restarts :export)) + (let ((p nil) + (*on-package-variance* '(:error t))) + (unwind-protect + (progn + (setf p (eval `(defpackage :package-at-variance-restarts.4 + (:export "FOO")))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::keep-them)))) + (eval `(defpackage :package-at-variance-restarts.4))) + (assert (eq :external (nth-value 1 (find-symbol "FOO" p)))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::drop-them)))) + (eval `(defpackage :package-at-variance-restarts.4))) + (assert (eq :internal (nth-value 1 (find-symbol "FOO" p))))) + (when p (delete-package p))))) + +(with-test (:name (:package-at-variance-restarts :implement)) + (let ((p nil) + (*on-package-variance* '(:error t))) + (unwind-protect + (progn + (setf p (eval `(defpackage :package-at-variance-restarts.5 + (:implement :sb-int)))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::keep-them)))) + (eval `(defpackage :package-at-variance-restarts.5))) + (assert (member p (package-implemented-by-list :sb-int))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::drop-them)))) + (eval `(defpackage :package-at-variance-restarts.5))) + (assert (not (member p (package-implemented-by-list :sb-int))))) + (when p (delete-package p))))) + +(with-test (:name (:delete-package :implementation-package)) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1") + p2 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2")) + (add-implementation-package p2 p1) + (assert (= 1 (length (package-implemented-by-list p1)))) + (delete-package p2) + (assert (= 0 (length (package-implemented-by-list p1))))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name (:delete-package :implementated-package)) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1") + p2 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2")) + (add-implementation-package p2 p1) + (assert (= 1 (length (package-implements-list p2)))) + (delete-package p1) + (assert (= 0 (length (package-implements-list p2))))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :package-local-nicknames) + ;; Clear slate + (without-package-locks + (when (find-package :package-local-nicknames-test-1) + (delete-package :package-local-nicknames-test-1)) + (when (find-package :package-local-nicknames-test-2) + (delete-package :package-local-nicknames-test-2))) + (eval `(defpackage :package-local-nicknames-test-1 + (:local-nicknames (:l :cl) (:sb :sb-ext)))) + (eval `(defpackage :package-local-nicknames-test-2 + (:export "CONS"))) + ;; Introspection + (let ((alist (package-local-nicknames :package-local-nicknames-test-1))) + (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=))) + (assert (equal (cons "SB" (find-package "SB-EXT")) (assoc "SB" alist :test 'string=))) + (assert (eql 2 (length alist)))) + ;; Usage + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((cons0 (read-from-string "L:CONS")) + (exit0 (read-from-string "SB:EXIT")) + (cons1 (find-symbol "CONS" :l)) + (exit1 (find-symbol "EXIT" :sb)) + (cl (find-package :l)) + (sb (find-package :sb))) + (assert (eq 'cons cons0)) + (assert (eq 'cons cons1)) + (assert (equal "L:CONS" (prin1-to-string cons0))) + (assert (eq 'sb-ext:exit exit0)) + (assert (eq 'sb-ext:exit exit1)) + (assert (equal "SB:EXIT" (prin1-to-string exit0))) + (assert (eq cl (find-package :common-lisp))) + (assert (eq sb (find-package :sb-ext))))) + ;; Can't add same name twice for different global names. + (assert (eq :oopsie + (handler-case + (add-package-local-nickname :l :package-local-nicknames-test-2 + :package-local-nicknames-test-1) + (error () + :oopsie)))) + ;; But same name twice is OK. + (add-package-local-nickname :l :cl :package-local-nicknames-test-1) + ;; Removal. + (assert (remove-package-local-nickname :l :package-local-nicknames-test-1)) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((exit0 (read-from-string "SB:EXIT")) + (exit1 (find-symbol "EXIT" :sb)) + (sb (find-package :sb))) + (assert (eq 'sb-ext:exit exit0)) + (assert (eq 'sb-ext:exit exit1)) + (assert (equal "SB:EXIT" (prin1-to-string exit0))) + (assert (eq sb (find-package :sb-ext))) + (assert (not (find-package :l))))) + ;; Adding back as another package. + (assert (eq (find-package :package-local-nicknames-test-1) + (add-package-local-nickname :l :package-local-nicknames-test-2 + :package-local-nicknames-test-1))) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((cons0 (read-from-string "L:CONS")) + (exit0 (read-from-string "SB:EXIT")) + (cons1 (find-symbol "CONS" :l)) + (exit1 (find-symbol "EXIT" :sb)) + (cl (find-package :l)) + (sb (find-package :sb))) + (assert (eq cons0 cons1)) + (assert (not (eq 'cons cons0))) + (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2) + cons0)) + (assert (equal "L:CONS" (prin1-to-string cons0))) + (assert (eq 'sb-ext:exit exit0)) + (assert (eq 'sb-ext:exit exit1)) + (assert (equal "SB:EXIT" (prin1-to-string exit0))) + (assert (eq cl (find-package :package-local-nicknames-test-2))) + (assert (eq sb (find-package :sb-ext))))) + ;; Interaction with package locks. + (lock-package :package-local-nicknames-test-1) + (assert (eq :package-oopsie + (handler-case + (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1) + (package-lock-violation () + :package-oopsie)))) + (assert (eq :package-oopsie + (handler-case + (remove-package-local-nickname :l :package-local-nicknames-test-1) + (package-lock-violation () + :package-oopsie)))) + (unlock-package :package-local-nicknames-test-1) + (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1) + (remove-package-local-nickname :l :package-local-nicknames-test-1)) + +(defmacro with-tmp-packages (bindings &body body) + `(let ,(mapcar #'car bindings) + (unwind-protect + (progn + (setf ,@(apply #'append bindings)) + ,@body) + ,@(mapcar (lambda (p) + `(when ,p (delete-package ,p))) + (mapcar #'car bindings))))) + +(with-test (:name (:delete-package :locally-nicknames-others)) + (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS")) + (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS"))) + (add-package-local-nickname :foo p2 p1) + (assert (equal (list p1) (package-locally-nicknamed-by-list p2))) + (delete-package p1) + (assert (not (package-locally-nicknamed-by-list p2))))) + +(with-test (:name (:delete-package :locally-nicknamed-by-others)) + (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS")) + (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS"))) + (add-package-local-nickname :foo p2 p1) + (assert (package-local-nicknames p1)) + (delete-package p2) + (assert (not (package-local-nicknames p1))))) + +(with-test (:name :own-name-as-local-nickname) + (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1")) + (p2 (make-package "OWN-NAME-AS-NICKNAME2"))) + (assert (eq :oops + (handler-case + (add-package-local-nickname :own-name-as-nickname1 p2 p1) + (error () + :oops)))) + (handler-bind ((error #'continue)) + (add-package-local-nickname :own-name-as-nickname1 p2 p1)) + (assert (eq (intern "FOO" p2) + (let ((*package* p1)) + (intern "FOO" :own-name-as-nickname1)))))) + +(with-test (:name :own-nickname-as-local-nickname) + (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1" + :nicknames '("OWN-NICKNAME"))) + (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2"))) + (assert (eq :oops + (handler-case + (add-package-local-nickname :own-nickname p2 p1) + (error () + :oops)))) + (handler-bind ((error #'continue)) + (add-package-local-nickname :own-nickname p2 p1)) + (assert (eq (intern "FOO" p2) + (let ((*package* p1)) + (intern "FOO" :own-nickname)))))) + +(with-test (:name :delete-package-restart) + (let* (ok + (result + (handler-bind + ((sb-kernel:simple-package-error + (lambda (c) + (setf ok t) + (continue c)))) + (delete-package (gensym))))) + (assert ok) + (assert (not result))))