Fix make-array transforms.

[sbcl.git] / tests / packages.impure.lisp

diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp
index 4008419..da555f4 100644 (file)
--- 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
@@ -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
@@ -491,3 +495,159 @@ if a restart was invoked."
            (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))))