X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpackages.impure.lisp;h=da555f42c4b552fe3b3dbaa24d22b57341901369;hb=9c9d6dbdc28a8bfe70be09f35263e9ec02411d0e;hp=a67dca2204b6e4c0209d50c8aa6c140f474a7546;hpb=f1e41363fc77b7fc7da410eafef587b683be777a;p=sbcl.git diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index a67dca2..da555f4 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -117,7 +117,7 @@ if a restart was invoked." ;;;; Tests ;;; USE-PACKAGE -(with-test (:name use-package.1) +(with-test (:name :use-package.1) (with-packages (("FOO" (:export "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use))) @@ -127,7 +127,7 @@ if a restart was invoked." (is (eq (sym "BAR" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name use-package.2) +(with-test (:name :use-package.2) (with-packages (("FOO" (:export "SYM")) ("BAZ" (:use) (:intern "SYM"))) (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp) @@ -136,7 +136,7 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name use-package.2a) +(with-test (:name :use-package.2a) (with-packages (("FOO" (:export "SYM")) ("BAZ" (:use) (:intern "SYM"))) (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp) @@ -145,7 +145,7 @@ if a restart was invoked." (is (equal (list (sym "BAZ" "SYM") :internal) (multiple-value-list (sym "BAZ" "SYM"))))))) -(with-test (:name use-package-conflict-set :fails-on :sbcl) +(with-test (:name :use-package-conflict-set :fails-on :sbcl) (with-packages (("FOO" (:export "SYM")) ("QUX" (:export "SYM")) ("BAR" (:intern "SYM")) @@ -167,7 +167,7 @@ if a restart was invoked." conflict-set))))) ;;; EXPORT -(with-test (:name export.1) +(with-test (:name :export.1) (with-packages (("FOO" (:intern "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use "FOO" "BAR"))) @@ -177,7 +177,7 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name export.1a) +(with-test (:name :export.1a) (with-packages (("FOO" (:intern "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use "FOO" "BAR"))) @@ -187,7 +187,7 @@ if a restart was invoked." (is (eq (sym "BAR" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name export.ensure-exported) +(with-test (:name :export.ensure-exported) (with-packages (("FOO" (:intern "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM"))) @@ -199,7 +199,7 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name export.3.intern) +(with-test (:name :export.3.intern) (with-packages (("FOO" (:intern "SYM")) ("BAZ" (:use "FOO") (:intern "SYM"))) (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp) @@ -208,7 +208,7 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name export.3a.intern) +(with-test (:name :export.3a.intern) (with-packages (("FOO" (:intern "SYM")) ("BAZ" (:use "FOO") (:intern "SYM"))) (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp) @@ -218,7 +218,7 @@ if a restart was invoked." (multiple-value-list (sym "BAZ" "SYM"))))))) ;;; IMPORT -(with-test (:name import-nil.1) +(with-test (:name :import-nil.1) (with-packages (("FOO" (:use) (:intern "NIL")) ("BAZ" (:use) (:intern "NIL"))) (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp) @@ -227,7 +227,7 @@ if a restart was invoked." (is (eq (sym "FOO" "NIL") (sym "BAZ" "NIL")))))) -(with-test (:name import-nil.2) +(with-test (:name :import-nil.2) (with-packages (("BAZ" (:use) (:intern "NIL"))) (with-name-conflict-resolution ('CL:NIL :restarted restartedp) (import '(CL:NIL) "BAZ") @@ -235,7 +235,7 @@ if a restart was invoked." (is (eq 'CL:NIL (sym "BAZ" "NIL")))))) -(with-test (:name import-single-conflict :fails-on :sbcl) +(with-test (:name :import-single-conflict :fails-on :sbcl) (with-packages (("FOO" (:export "NIL")) ("BAR" (:export "NIL")) ("BAZ" (:use))) @@ -253,7 +253,7 @@ if a restart was invoked." ;;; Make sure that resolving a name-conflict in IMPORT doesn't leave ;;; multiple symbols of the same name in the package (this particular ;;; scenario found in 1.0.38.9, but clearly a longstanding issue). -(with-test (:name import-conflict-resolution) +(with-test (:name :import-conflict-resolution) (with-packages (("FOO" (:export "NIL")) ("BAR" (:use))) (with-name-conflict-resolution ((sym "FOO" "NIL")) @@ -262,7 +262,7 @@ if a restart was invoked." (assert (eq sym (sym "FOO" "NIL")))))) ;;; UNINTERN -(with-test (:name unintern.1) +(with-test (:name :unintern.1) (with-packages (("FOO" (:export "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use "FOO" "BAR") (:shadow "SYM"))) @@ -272,13 +272,13 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name unintern.2) +(with-test (:name :unintern.2) (with-packages (("FOO" (:intern "SYM"))) (unintern :sym "FOO") (assert (find-symbol "SYM" "FOO")))) ;;; WITH-PACKAGE-ITERATOR error signalling had problems -(with-test (:name with-package-itarator.error) +(with-test (:name :with-package-iterator.error) (assert (eq :good (handler-case (progn @@ -499,8 +499,10 @@ if a restart was invoked." (with-test (:name :package-local-nicknames) ;; Clear slate (without-package-locks - (delete-package :package-local-nicknames-test-1) - (delete-package :package-local-nicknames-test-2)) + (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 @@ -583,23 +585,69 @@ if a restart was invoked." (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)) - (let (p1 p2) - (unwind-protect - (progn - (setf 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)))) - (when p1 (delete-package p1)) - (when p2 (delete-package p2))))) + (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)) - (let ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS")) - (p2 (make-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))))