From: Nikodemus Siivola Date: Fri, 1 Feb 2013 12:49:41 +0000 (+0200) Subject: DEFPACKAGE at variance restarts X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=447788f1b408a8e9ec15ca822851dcd0bee52f82;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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)))))