From: Nikodemus Siivola Date: Fri, 1 Feb 2013 18:13:31 +0000 (+0200) Subject: restore old behaviour as the default for package variance X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6129b1ebc5125c57d6446c061155f5f653f41725;p=sbcl.git restore old behaviour as the default for package variance Use *on-package-variance* to adjust. Hint: (setf *on-package-variance* '(:warn (:swank :swank-backend) :error t)) --- diff --git a/NEWS b/NEWS index 5f2996c..6c28b57 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,13 @@ changes relative to sbcl-1.1.4: resulting from IMPORT, EXPORT, or USE-PACKAGE. * enhancement: variant DEFPACKAGE forms now signal a full error with restarts provided for resolving the situation. (lp#891351) + * enhancement: by setting SB-EXT:*ON-PACKAGE-VARIANCE* to :ERROR variant + DEFPACKAGE forms now signal a full error with restarts provided for + resolving the situation. Default is :WARN, which retains the previous + behaviour. (lp#891351) + * enhancement: easier to read method names in backtraces. + * bug fix: secondary CLOS dispatch functions have better debug names. + (lp#503081) * bug fix: deleting a package removes it from implementation-package lists of other packages. diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index 0cb3688..348208c 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -94,6 +94,19 @@ Example: @include fun-sb-ext-add-package-local-nickname.texinfo @include fun-sb-ext-remove-package-local-nickname.texinfo +@node Package Variance +@comment node-name, next, previous, up +@section Package Variance + +Common Lisp standard specifies that ``If the new definition is at +variance with the current state of that package, the consequences are +undefined;'' SBCL by default signals a full warning and retains as +much of the package state as possible. + +This can be adjusted using @code{sb-ext:*on-package-variance*}: + +@include var-sb-ext-star-on-package-variance-star.texinfo + @node Garbage Collection @comment node-name, next, previous, up @section Garbage Collection diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 413de56..971ab42 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -709,6 +709,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "REMOVE-PACKAGE-LOCAL-NICKNAME" "PACKAGE-LOCAL-NICKNAMES" "PACKAGE-LOCALLY-NICKNAMED-BY" + ;; behaviour on DEFPACKAGE variance + "*ON-PACKAGE-VARIANCE*" ;; Custom conditions & condition accessors for users to handle. "CODE-DELETION-NOTE" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 99d0995..faa0447 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -912,7 +912,8 @@ (define-condition package-at-variance (reference-condition simple-warning) () - (:default-initargs :references (list '(:ansi-cl :macro defpackage)))) + (:default-initargs :references (list '(:ansi-cl :macro defpackage) + '(:sbcl :variable *on-package-variance*)))) (define-condition package-at-variance-error (reference-condition simple-condition package-error) diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 003a73c..ae4d051 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -262,6 +262,46 @@ (add-package-local-nickname (car spec) (cdr spec) package)) package) +(declaim (type list *on-package-variance*)) +(defvar *on-package-variance* '(:warn t) + "Specifies behavior when redefining a package using DEFPACKAGE and the +definition is in variance with the current state of the package. + +The value should be of the form: + + (:WARN [T | packages-names] :ERROR [T | package-names]) + +specifying which packages get which behaviour -- with T signifying the default unless +otherwise specified. If default is not specified, :WARN is used. + +:WARN keeps as much state as possible and causes SBCL to signal a full warning. + +:ERROR causes SBCL to signal an error when the variant DEFPACKAGE form is executed, +with restarts provided for user to specify what action should be taken. + +Example: + + (setf *on-package-variance* '(:warn (:swank :swank-backend) :error t)) + +specifies to signal a warning if SWANK package is in variance, and an error otherwise.") + +(defun note-package-variance (&rest args &key package &allow-other-keys) + (let ((pname (package-name package))) + (destructuring-bind (&key warn error) *on-package-variance* + (let ((what (cond ((and (listp error) (member pname error :test #'string=)) + :error) + ((and (listp warn) (member pname warn :test #'string=)) + :warn) + ((eq t error) + :error) + (t + :warn)))) + (ecase what + (:error + (apply #'error 'sb!kernel::package-at-variance-error args)) + (:warn + (apply #'warn 'sb!kernel::package-at-variance args))))))) + (defun update-package-with-variance (package name nicknames source-location shadows shadowing-imports use @@ -281,10 +321,10 @@ (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)) + (note-package-variance + :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) @@ -294,10 +334,10 @@ (let ((no-longer-used (set-difference (package-use-list package) use))) (when no-longer-used (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) + (note-package-variance + :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)) @@ -309,10 +349,10 @@ (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) + (note-package-variance + :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)) @@ -323,10 +363,10 @@ (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) + (note-package-variance + :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) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index fc49997..ae0228e 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