X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpackages.impure.lisp;h=fbe8e5b6d8033800715d6e6e54cd4579abe1abb0;hb=0b3f5cc5fa9e6b121d232960ccd964d2eb15f695;hp=fc4999798b01849b67ca2cd9110141b05864dfe8;hpb=b0b221088b889b6d3ae67e551b93fe1a6cfec878;p=sbcl.git

diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp
index fc49997..fbe8e5b 100644
--- a/tests/packages.impure.lisp
+++ b/tests/packages.impure.lisp
@@ -390,7 +390,8 @@ if a restart was invoked."
       (when p2 (delete-package p2)))))
 
 (with-test (:name (:package-at-variance-restarts :shadow))
-  (let (p)
+  (let ((p nil)
+        (*on-package-variance* '(:error t)))
     (unwind-protect
          (progn
            (setf p (eval `(defpackage :package-at-variance-restarts.1
@@ -411,7 +412,8 @@ if a restart was invoked."
       (when p (delete-package p)))))
 
 (with-test (:name (:package-at-variance-restarts :use))
-  (let (p)
+  (let ((p nil)
+        (*on-package-variance* '(:error t)))
     (unwind-protect
          (progn
            (setf p (eval `(defpackage :package-at-variance-restarts.2
@@ -431,7 +433,8 @@ if a restart was invoked."
       (when p (delete-package p)))))
 
 (with-test (:name (:package-at-variance-restarts :export))
-  (let (p)
+  (let ((p nil)
+        (*on-package-variance* '(:error t)))
     (unwind-protect
          (progn
            (setf p (eval `(defpackage :package-at-variance-restarts.4
@@ -449,7 +452,8 @@ if a restart was invoked."
       (when p (delete-package p)))))
 
 (with-test (:name (:package-at-variance-restarts :implement))
-  (let (p)
+  (let ((p nil)
+        (*on-package-variance* '(:error t)))
     (unwind-protect
          (progn
            (setf p (eval `(defpackage :package-at-variance-restarts.5
@@ -495,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
@@ -579,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 (package-locally-nicknamed-by p2))
-               (delete-package p1)
-               (assert (not (package-locally-nicknamed-by 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))))