From da554aabb26815adee15c78dd41ced81dd7fd5d2 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 26 Oct 2004 11:43:49 +0000 Subject: [PATCH] 0.8.16.4: Fix for bug reported by Bruno Haible cmucl-imp 2004-10-19: ... be more clear about when situations are name conflicts ... signal symbol-by-symbol rather than all at once, so that... ... a restart can be offered to resolve the conflicts in favour of any of the conflicting symbols ... document the condition type, symbol list accessor and restart ... also frob the docstrings a little for sbcl house style --- NEWS | 10 +- doc/manual/beyond-ansi.texinfo | 14 +- package-data-list.lisp-expr | 4 + src/code/defboot.lisp | 5 +- src/code/target-package.lisp | 387 ++++++++++++++++++++++++---------------- version.lisp-expr | 2 +- 6 files changed, 265 insertions(+), 157 deletions(-) diff --git a/NEWS b/NEWS index 316655a..0b85b4a 100644 --- a/NEWS +++ b/NEWS @@ -1,11 +1,17 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16: * bug fix: READ, READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ-FROM-STRING all now return a primary value of NIL if - *READ-SUPPRESS* is true. (reported by Bruno Haible for CMUCL) + *READ-SUPPRESS* is true. (reported by Bruno Haible for CMUCL) * bug fix: Default value of EOF-ERROR-P in READ-FROM-STRING is true. (reported by Bruno Haible for CMUCL) * bug fix: ERROR now signals a TYPE-ERROR if the arguments to ERROR - do not designate a condition. (reported by Bruno Haible for CMUCL) + do not designate a condition. (reported by Bruno Haible for + CMUCL) + * bug fix: UNINTERN, USE-PACKAGE, IMPORT and EXPORT all signal an + SB-EXT:NAME-CONFLICT condition (subtype of PACKAGE-ERROR) in the + name conflict situations in CLHS 11.1.1.2.5, and provide a restart + permitting resolution in favour of any of the conflicting symbols. + (reported by Bruno Haible for CMUCL) changes in sbcl-0.8.16 relative to sbcl-0.8.15: * enhancement: saving cores with foreign code loaded is now diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index fdf8b69..a0bffa2 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -11,6 +11,7 @@ it still has quite a few. @xref{Contributed Modules}. * Support For Unix:: * Customization Hooks for Users:: * Tools To Help Developers:: +* Resolution of Name Conflicts:: * Stale Extensions:: * Efficiency Hacks:: @end menu @@ -92,7 +93,7 @@ mechanisms as follows: @include fun-common-lisp-ed.texinfo @include var-sb-ext-star-ed-functions-star.texinfo -@node Tools To Help Developers +@node Tools To Help Developers @comment node-name, next, previous, up @section Tools To Help Developers @@ -105,6 +106,17 @@ accessed by typing @kbd{help} at the debugger prompt. @xref{Debugger}. Documentation for @code{inspect} is accessed by typing @kbd{help} at the @code{inspect} prompt. +@node Resolution of Name Conflicts +@section Resolution of Name Conflicts + +The ANSI standard (section 11.1.1.2.5) requires that name conflicts in +packages be resolvable in favour of any of the conflicting symbols. In +the interactive debugger, this is achieved by prompting for the symbol +in whose favour the conflict should be resolved; for programmatic use, +the @code{sb-ext:resolve-conflict} restart should be invoked with one +argument, which should be a member of the list returned by the condition +accessor @code{sb-ext:name-conflict-symbols}. + @node Stale Extensions @comment node-name, next, previous, up @section Stale Extensions diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 484b83a..f5a919e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -866,6 +866,10 @@ retained, possibly temporariliy, because it might be used internally." "FORMAT-ARGS-MISMATCH" "FORMAT-TOO-FEW-ARGS-WARNING" "FORMAT-TOO-MANY-ARGS-WARNING" "EXTENSION-FAILURE" + "NAME-CONFLICT" "NAME-CONFLICT-FUNCTION" + "NAME-CONFLICT-DATUM" "NAME-CONFLICT-SYMBOLS" + "RESOLVE-CONFLICT" + ;; ..and DEFTYPEs.. "INDEX" "LOAD/STORE-INDEX" "SIGNED-BYTE-WITH-A-BITE-OUT" diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 964639f..d18391e 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -352,9 +352,8 @@ (defmacro-mundanely with-condition-restarts (condition-form restarts-form &body body) #!+sb-doc - "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form* - Evaluates the Forms in a dynamic environment where the restarts in the list - Restarts-Form are associated with the condition returned by Condition-Form. + "Evaluates the BODY in a dynamic environment where the restarts in the list + RESTARTS-FORM are associated with the condition returned by CONDITION-FORM. This allows FIND-RESTART, etc., to recognize restarts that are not related to the error currently being debugged. See also RESTART-CASE." (let ((n-cond (gensym))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 2019023..4a6f3da 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -477,20 +477,15 @@ error if any of PACKAGES is not a valid package designator." (push n (package-%nicknames package))) ((eq found package)) ((string= (the string (package-%name found)) n) - ;; FIXME: This and the next error needn't have restarts. - (with-simple-restart (continue "Ignore this nickname.") - (error 'simple-package-error - :package package - :format-control "~S is a package name, so it cannot be a nickname for ~S." - :format-arguments (list n (package-%name package))))) + (error 'simple-package-error + :package package + :format-control "~S is a package name, so it cannot be a nickname for ~S." + :format-arguments (list n (package-%name package)))) (t - (with-simple-restart (continue "Redefine this nickname.") - (error 'simple-package-error - :package package - :format-control "~S is already a nickname for ~S." - :format-arguments (list n (package-%name found)))) - (setf (gethash n *package-names*) package) - (push n (package-%nicknames package))))))) + (error 'simple-package-error + :package package + :format-control "~S is already a nickname for ~S." + :format-arguments (list n (package-%name found)))))))) (defun make-package (name &key (use '#.*default-package-use-list*) @@ -575,19 +570,23 @@ error if any of PACKAGES is not a valid package designator." (enter-new-nicknames package nicknames)) package)) -(defun delete-package (package-or-name) +(defun delete-package (package-designator) #!+sb-doc - "Delete the package-or-name from the package system data structures." - (let ((package (if (packagep package-or-name) - package-or-name - (find-package package-or-name)))) + "Delete the package designated by PACKAGE-DESIGNATOR from the package + system data structures." + (let ((package (if (packagep package-designator) + package-designator + (find-package package-designator)))) (cond ((not package) ;; This continuable error is required by ANSI. - (with-simple-restart (continue "Return NIL") - (error 'simple-package-error - :package package-or-name - :format-control "There is no package named ~S." - :format-arguments (list package-or-name)))) + (cerror + "Return ~S." + (make-condition + 'simple-package-error + :package package-designator + :format-control "There is no package named ~S." + :format-arguments (list package-designator)) + nil)) ((not (package-name package)) ; already deleted nil) (t @@ -596,15 +595,16 @@ error if any of PACKAGES is not a valid package designator." (let ((use-list (package-used-by-list package))) (when use-list ;; This continuable error is specified by ANSI. - (with-simple-restart - (continue "Remove dependency in other packages.") - (error 'simple-package-error - :package package - :format-control - "Package ~S is used by package(s):~% ~S" - :format-arguments - (list (package-name package) - (mapcar #'package-name use-list)))) + (cerror + "Remove dependency in other packages." + (make-condition + 'simple-package-error + :package package + :format-control + "~@" + :format-arguments (list (package-name package) + (length use-list) + (mapcar #'package-name use-list)))) (dolist (p use-list) (unuse-package package p)))) (dolist (used (package-use-list package)) @@ -642,7 +642,8 @@ error if any of PACKAGES is not a valid package designator." (defun intern (name &optional (package (sane-package))) #!+sb-doc - "Return a symbol having the specified name, creating it if necessary." + "Return a symbol in PACKAGE having the specified NAME, creating it + if necessary." ;; We just simple-stringify the name and call INTERN*, where the real ;; logic is. (let ((name (if (simple-string-p name) @@ -656,8 +657,8 @@ error if any of PACKAGES is not a valid package designator." (defun find-symbol (name &optional (package (sane-package))) #!+sb-doc - "Return the symbol named String in Package. If such a symbol is found - then the second value is :internal, :external or :inherited to indicate + "Return the symbol named STRING in PACKAGE. If such a symbol is found + then the second value is :INTERNAL, :EXTERNAL or :INHERITED to indicate how the symbol is accessible. If no symbol is found then both values are NIL." ;; We just simple-stringify the name and call FIND-SYMBOL*, where the @@ -715,7 +716,7 @@ error if any of PACKAGES is not a valid package designator." (shiftf (cdr prev) (cdr table) (cdr head) table)) (return-from find-symbol* (values symbol :inherited)))))))) -;;; Similar to Find-Symbol, but only looks for an external symbol. +;;; Similar to FIND-SYMBOL, but only looks for an external symbol. ;;; This is used for fast name-conflict checking in this file and symbol ;;; printing in the printer. (defun find-external-symbol (string package) @@ -728,12 +729,145 @@ error if any of PACKAGES is not a valid package designator." string length hash ehash) (values symbol found)))) +(define-condition name-conflict (reference-condition package-error) + ((function :initarg :function :reader name-conflict-function) + (datum :initarg :datum :reader name-conflict-datum) + (symbols :initarg :symbols :reader name-conflict-symbols)) + (:default-initargs :references (list '(:ansi-cl :section (11 1 1 2 5)))) + (:report + (lambda (c s) + (format s "~@<~S ~S causes name-conflicts in ~S between the ~ + following symbols:~2I~@:_~{~S~^, ~}~:@>" + (name-conflict-function c) + (name-conflict-datum c) + (package-error-package c) + (name-conflict-symbols c))))) + +(defun name-conflict (package function datum &rest symbols) + (restart-case + (error 'name-conflict :package package :symbols symbols + :function function :datum datum) + (resolve-conflict (s) + :report "Resolve conflict." + :interactive + (lambda () + (let* ((len (length symbols)) + (nlen (length (write-to-string len :base 10)))) + (format *query-io* "~&~@