DEFPACKAGE at variance restarts

  Signal a full error on variances, in each case offering the user the
  choice of keeping the old stuff or dropping it.

  Fixes lp#891351.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 691a040..a94fa38 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1080,7 +1080,9 @@ possibly temporariliy, because it might be used internally."
                "*PRINT-CONDITION-REFERENCES*"
 
                "DUPLICATE-DEFINITION" "DUPLICATE-DEFINITION-NAME"
-               "PACKAGE-AT-VARIANCE" "ARRAY-INITIAL-ELEMENT-MISMATCH"
+               "PACKAGE-AT-VARIANCE"
+               "PACKAGE-AT-VARIANCE-ERROR"
+               "ARRAY-INITIAL-ELEMENT-MISMATCH"
                "TYPE-WARNING" "TYPE-STYLE-WARNING"
                "LOCAL-ARGUMENT-MISMATCH"
                "FORMAT-ARGS-MISMATCH" "FORMAT-TOO-FEW-ARGS-WARNING"

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index a0f108a..99d0995 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -914,6 +914,11 @@
   ()
   (:default-initargs :references (list '(:ansi-cl :macro defpackage))))
 
+(define-condition package-at-variance-error (reference-condition simple-condition
+                                             package-error)
+  ()
+  (:default-initargs :references (list '(:ansi-cl :macro defpackage))))
+
 (define-condition defconstant-uneql (reference-condition error)
   ((name :initarg :name :reader defconstant-uneql-name)
    (old-value :initarg :old-value :reader defconstant-uneql-old-value)

diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp
index 3e76f63..435bd0d 100644 (file)
--- a/src/code/defpackage.lisp
+++ b/src/code/defpackage.lisp
@@ -253,41 +253,74 @@
                                      imports interns
                                      exports
                                      implement lock doc-string)
-  (let ((old-exports nil)
-        (old-shadows (package-%shadowing-symbols package))
-        (old-use (package-use-list package))
-        (no-longer-used nil))
-    (unless (string= (the string (package-name package)) name)
-      (error 'simple-package-error
-             :package name
-             :format-control "~A is a nickname for the package ~A"
-             :format-arguments (list name (package-name name))))
-    (do-external-symbols (symbol package)
-      (push symbol old-exports))
-    (setf old-shadows (set-difference old-shadows (append shadows
-                                                          shadowing-imports)
-                                      :test #'string=))
-    (setf no-longer-used (set-difference old-use use))
-    (setf use (set-difference use old-use))
-    (setf old-exports (set-difference old-exports exports :test #'string=))
-    (when old-shadows
-      (warn 'package-at-variance
-            :format-control "~A also shadows the following symbols:~%  ~S"
-            :format-arguments (list name old-shadows)))
+  (unless (string= (the string (package-name package)) name)
+    (error 'simple-package-error
+           :package name
+           :format-control "~A is a nickname for the package ~A"
+           :format-arguments (list name (package-name name))))
+  (let ((no-longer-shadowed
+          (set-difference (package-%shadowing-symbols package)
+                          (append shadows shadowing-imports)
+                          :test #'string=)))
+    (when no-longer-shadowed
+      (restart-case
+          (let ((*package* (find-package :keyword)))
+            (error 'sb!kernel::package-at-variance-error
+                   :format-control "~A also shadows the following symbols:~%  ~S"
+                   :format-arguments (list name no-longer-shadowed)
+                   :package package))
+        (drop-them ()
+          :report "Stop shadowing them by uninterning them."
+          (dolist (sym no-longer-shadowed)
+            (unintern sym package)))
+        (keep-them ()
+          :report "Keep shadowing them."))))
+  (let ((no-longer-used (set-difference (package-use-list package) use)))
     (when no-longer-used
-      (dolist (unused-package no-longer-used)
-        (unuse-package unused-package package))
-      (warn 'package-at-variance
-            :format-control "~A used to use the following packages:~%  ~S"
-            :format-arguments (list name no-longer-used)))
-    (when old-exports
-      (warn 'package-at-variance
-            :format-control "~A also exports the following symbols:~%  ~S"
-            :format-arguments (list name old-exports)))
-    (update-package package nicknames source-location
-                    shadows shadowing-imports
-                    use imports interns exports
-                    implement lock doc-string)))
+      (restart-case
+          (error 'sb!kernel::package-at-variance-error
+                 :format-control "~A also uses the following packages:~%  ~A"
+                 :format-arguments (list name (mapcar #'package-name no-longer-used))
+                 :package package)
+        (drop-them ()
+          :report "Stop using them."
+          (unuse-package no-longer-used package))
+        (keep-them ()
+          :report "Keep using them."))))
+  (let (old-exports)
+    (do-external-symbols (s package)
+      (push s old-exports))
+    (let ((no-longer-exported (set-difference old-exports exports :test #'string=)))
+     (when no-longer-exported
+       (restart-case
+           (error 'sb!kernel::package-at-variance-error
+                  :format-control "~A also exports the following symbols:~%  ~S"
+                  :format-arguments (list name no-longer-exported)
+                  :package package)
+         (drop-them ()
+           :report "Unexport them."
+           (unexport no-longer-exported package))
+         (keep-them ()
+           :report "Keep exporting them.")))))
+  (let ((old-implements
+          (set-difference (package-implements-list package)
+                          (mapcar #'find-undeleted-package-or-lose implement))))
+    (when old-implements
+      (restart-case
+          (error 'sb!kernel::package-at-variance-error
+                 :format-control "~A is also an implementation package for:~% ~{~S~^~%  ~}"
+                 :format-arguments (list name old-implements)
+                 :package package)
+        (drop-them ()
+          :report "Stop being an implementation package for them."
+          (dolist (p old-implements)
+            (remove-implementation-package package p)))
+        (keep-them ()
+          :report "Keep exporting them."))))
+  (update-package package nicknames source-location
+                  shadows shadowing-imports
+                  use imports interns exports
+                  implement lock doc-string))
 
 (defun %defpackage (name nicknames size shadows shadowing-imports
                     use imports interns exports implement lock doc-string

diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp
index 31046f5..80a807d 100644 (file)
--- a/tests/packages.impure.lisp
+++ b/tests/packages.impure.lisp
@@ -388,3 +388,80 @@ if a restart was invoked."
            (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)
+    (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)
+    (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)
+    (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)
+    (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)))))