From 56fd7d95cfadb61a353e8999111a0e2e6a94842b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 2 Aug 2008 08:27:30 +0000 Subject: [PATCH] 1.0.19.15: package name conflict patched from Michael Weber * Tests for package system name conflict resolution. * Fixed EXPORT bug which left symbol unexported in conflict situations. * Unbreak RESOLVE-CONFLICT restart: ** USEing packages with conflicting symbols ** Correctly handle conflicts involving CL:NIL by passing (list symbol) to package frobbing functions which take a list designator. * Removed commented-out version of NAME-CONFLICT. --- NEWS | 7 ++ src/code/target-package.lisp | 132 +++++++---------------------- tests/assertoid.lisp | 13 ++- tests/packages.impure.lisp | 193 ++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 242 insertions(+), 105 deletions(-) diff --git a/NEWS b/NEWS index b95aa43..c4b3346 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,13 @@ changes in sbcl-1.0.20 relative to 1.0.19: Michael Weber) * bug fix: calling SB-COVER:REPORT with a non-directory pathname now signals an error. (thanks to Pierre Mai) + * bug fix: EXPORT left symbol unexported in conflict situations. + (thanks to Michael Weber) + * bug fix: correctly handle name conflicts involving CL:NIL. + (thanks to Michael Weber) + * bug fix: RESOLVE-CONFLICT restart for name conflicts handles + conflicts arising from USEing package with conflicting symbols + correctly. (thanks to Michael Weber) changes in sbcl-1.0.19 relative to 1.0.18: * new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*; diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 890bd11..e92c43f 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -837,7 +837,7 @@ implementation it is ~S." *default-package-use-list*) (restart-case (error 'name-conflict :package package :symbols symbols :function function :datum datum) - (resolve-conflict (s) + (resolve-conflict (chosen-symbol) :report "Resolve conflict." :interactive (lambda () @@ -858,102 +858,32 @@ implementation it is ~S." *default-package-use-list*) (let ((i (parse-integer (read-line *query-io*) :junk-allowed t))) (when (and i (<= 1 i len)) (return (list (nth (1- i) symbols)))))))) - (multiple-value-bind (symbol status) - (find-symbol (symbol-name s) package) - (declare (ignore status)) ; FIXME: is that true? - (case function - ((export) - (if (eq symbol s) - (shadow symbol package) - (unintern symbol package))) - ((unintern) - (shadowing-import s package)) - ((import) - (if (eq symbol s) - nil ; do nothing - (shadowing-import s package))) - ((use-package) - (if (eq symbol s) - (shadow s package) - (shadowing-import s package)))))))) - -#+nil ; this solution gives a variable number of restarts instead, but - ; no good way of programmatically choosing between them. -(defun name-conflict (package function datum &rest symbols) - (let ((condition (make-condition 'name-conflict - :package package :symbols symbols - :function function :datum datum))) - ;; this is a gross violation of modularity, but I can't see any - ;; other way to have a variable number of restarts. - (let ((*restart-clusters* - (cons - (mapcan - (lambda (s) - (multiple-value-bind (accessible-symbol status) - (find-symbol (symbol-name s) package) - (cond - ;; difficult case - ((eq s accessible-symbol) - (ecase status - ((:inherited) - (list (make-restart - :name (make-symbol "SHADOWING-IMPORT") - :function (lambda () - (shadowing-import s package) - (return-from name-conflict)) - :report-function - (lambda (stream) - (format stream "Shadowing-import ~S into ~A." - s (package-%name package)))))) - ((:internal :external) - (aver (= (length symbols) 2)) - ;; ARGH! FIXME: this unintern restart can - ;; _still_ leave the system in an - ;; unsatisfactory state: if the symbol is a - ;; external symbol of a package which is - ;; already used by this package, and has also - ;; been imported, then uninterning it from this - ;; package will still leave it visible! - ;; - ;; (DEFPACKAGE "FOO" (:EXPORT "SYM")) - ;; (DEFPACKAGE "BAR" (:EXPORT "SYM")) - ;; (DEFPACKAGE "BAZ" (:USE "FOO")) - ;; (IMPORT 'FOO:SYM "BAZ") - ;; (USE-PACKAGE "BAR" "BAZ") - ;; - ;; Now (UNINTERN 'FOO:SYM "BAZ") doesn't - ;; resolve the conflict. :-( - ;; - ;; -- CSR, 2004-10-20 - (list (make-restart - :name (make-symbol "UNINTERN") - :function (lambda () - (unintern s package) - (import - (find s symbols :test-not #'eq) - package) - (return-from name-conflict)) - :report-function - (lambda (stream) - (format stream - "Unintern ~S from ~A and import ~S." - s - (package-%name package) - (find s symbols :test-not #'eq)))))))) - (t (list (make-restart - :name (make-symbol "SHADOWING-IMPORT") - :function (lambda () - (shadowing-import s package) - (return-from name-conflict)) - :report-function - (lambda (stream) - (format stream "Shadowing-import ~S into ~A." - s (package-%name package))))))))) - symbols) - *restart-clusters*))) - (with-condition-restarts condition (car *restart-clusters*) - (with-simple-restart (abort "Leave action undone.") - (error condition)))))) + (multiple-value-bind (package-symbol status) + (find-symbol (symbol-name chosen-symbol) package) + (let* ((accessiblep status) ; never NIL here + (presentp (and accessiblep + (not (eq :inherited status))))) + (ecase function + ((unintern) + (if presentp + (if (eq package-symbol chosen-symbol) + (shadow (list package-symbol) package) + (shadowing-import (list chosen-symbol) package)) + (shadowing-import (list chosen-symbol) package))) + ((use-package export) + (if presentp + (if (eq package-symbol chosen-symbol) + (shadow (list package-symbol) package) ; CLHS 11.1.1.2.5 + (if (eq (symbol-package package-symbol) package) + (unintern package-symbol package) ; CLHS 11.1.1.2.5 + (shadowing-import (list chosen-symbol) package))) + (shadowing-import (list chosen-symbol) package))) + ((import) + (if presentp + (if (eq package-symbol chosen-symbol) + nil ; re-importing the same symbol + (shadowing-import (list chosen-symbol) package)) + (shadowing-import chosen-symbol package))))))))) ;;; If we are uninterning a shadowing symbol, then a name conflict can ;;; result, otherwise just nuke the symbol. @@ -1048,8 +978,7 @@ uninterned." (assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}" (length syms) syms)) ;; Find symbols and packages with conflicts. - (let ((used-by (package-%used-by-list package)) - (cset ())) + (let ((used-by (package-%used-by-list package))) (dolist (sym syms) (let ((name (symbol-name sym))) (dolist (p used-by) @@ -1059,10 +988,7 @@ uninterned." (not (member s (package-%shadowing-symbols p)))) ;; Beware: the name conflict is in package P, not in ;; PACKAGE. - (name-conflict p 'export sym sym s) - (pushnew sym cset)))))) - (when cset - (setq syms (set-difference syms cset)))) + (name-conflict p 'export sym sym s))))))) ;; Check that all symbols are accessible. If not, ask to import them. (let ((missing ()) (imports ())) diff --git a/tests/assertoid.lisp b/tests/assertoid.lisp index 6f75873..a2bbd52 100644 --- a/tests/assertoid.lisp +++ b/tests/assertoid.lisp @@ -14,7 +14,7 @@ (cl:defpackage "ASSERTOID" (:use "CL") - (:export "GRAB-CONDITION" "RAISES-ERROR?" "ASSERTOID")) + (:export "GRAB-CONDITION" "RAISES-ERROR?" "IS" "ASSERTOID")) (cl:in-package "ASSERTOID") @@ -113,3 +113,14 @@ ;;; not implemented yet: #+nil (assertoid (length (eval (find-package :cl))) :expected-error-type 'type-error) + +(defmacro is (form) + (if (consp form) + (destructuring-bind (op expected real) form + `(let ((expected-value ,expected) + (real-value ,real)) + (unless (,op expected-value real-value) + (error "Wanted ~S, got ~S:~% ~S" + expected-value real-value ',form)))) + `(unless ,form + (error "~S evaluated to NIL" ',form)))) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index ce498d6..5078b9e 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -62,3 +62,196 @@ (assert (eql (find-package "A-NICKNAME") (find-package "TEST-ORIGINAL"))) +;;;; Utilities +(defun sym (package name) + (let ((package (or (find-package package) package))) + (multiple-value-bind (symbol status) + (find-symbol name package) + (assert status + (package name symbol status) + "No symbol with name ~A in ~S." name package symbol status) + (values symbol status)))) + +(defmacro with-name-conflict-resolution ((symbol &key restarted) + form &body body) + "Resolves potential name conflict condition arising from FORM. + +The conflict is resolved in favour of SYMBOL, a form which must +evaluate to a symbol. + +If RESTARTED is a symbol, it is bound for the BODY forms and set to T +if a restart was invoked." + (check-type restarted symbol "a binding name") + (let ((%symbol (copy-symbol 'symbol))) + `(let (,@(when restarted `((,restarted))) + (,%symbol ,symbol)) + (handler-bind + ((sb-ext:name-conflict + (lambda (condition) + ,@(when restarted `((setf ,restarted t))) + (assert (member ,%symbol (sb-ext:name-conflict-symbols condition))) + (invoke-restart 'sb-ext:resolve-conflict ,%symbol)))) + ,form) + ,@body))) + +(defmacro with-packages (specs &body forms) + (let ((names (mapcar #'car specs))) + `(unwind-protect + (progn + (delete-packages ',names) + ,@(mapcar (lambda (spec) + `(defpackage ,@spec)) + specs) + ,@forms) + (delete-packages ',names)))) + +(defun delete-packages (names) + (dolist (p names) + (ignore-errors (delete-package p)))) + + +;;;; Tests +;;; USE-PACKAGE +(with-test (:name use-package.1) + (with-packages (("FOO" (:export "SYM")) + ("BAR" (:export "SYM")) + ("BAZ" (:use))) + (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp) + (use-package '("FOO" "BAR") "BAZ") + (is restartedp) + (is (eq (sym "BAR" "SYM") + (sym "BAZ" "SYM")))))) + +(with-test (:name use-package.2) + (with-packages (("FOO" (:export "SYM")) + ("BAZ" (:use) (:intern "SYM"))) + (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp) + (use-package "FOO" "BAZ") + (is restartedp) + (is (eq (sym "FOO" "SYM") + (sym "BAZ" "SYM")))))) + +(with-test (:name use-package.2a) + (with-packages (("FOO" (:export "SYM")) + ("BAZ" (:use) (:intern "SYM"))) + (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp) + (use-package "FOO" "BAZ") + (is restartedp) + (is (equal (list (sym "BAZ" "SYM") :internal) + (multiple-value-list (sym "BAZ" "SYM"))))))) + +(with-test (:name use-package-conflict-set :fails-on :sbcl) + (with-packages (("FOO" (:export "SYM")) + ("QUX" (:export "SYM")) + ("BAR" (:intern "SYM")) + ("BAZ" (:use) (:import-from "BAR" "SYM"))) + (let ((conflict-set)) + (block nil + (handler-bind + ((sb-ext:name-conflict + (lambda (condition) + (setf conflict-set (copy-list + (sb-ext:name-conflict-symbols condition))) + (return)))) + (use-package '("FOO" "QUX") "BAZ"))) + (setf conflict-set + (sort conflict-set #'string< + :key (lambda (symbol) + (package-name (symbol-package symbol))))) + (is (equal (list (sym "BAR" "SYM") (sym "FOO" "SYM") (sym "QUX" "SYM")) + conflict-set))))) + +;;; EXPORT +(with-test (:name export.1) + (with-packages (("FOO" (:intern "SYM")) + ("BAR" (:export "SYM")) + ("BAZ" (:use "FOO" "BAR"))) + (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp) + (export (sym "FOO" "SYM") "FOO") + (is restartedp) + (is (eq (sym "FOO" "SYM") + (sym "BAZ" "SYM")))))) + +(with-test (:name export.1a) + (with-packages (("FOO" (:intern "SYM")) + ("BAR" (:export "SYM")) + ("BAZ" (:use "FOO" "BAR"))) + (with-name-conflict-resolution ((sym "BAR" "SYM") :restarted restartedp) + (export (sym "FOO" "SYM") "FOO") + (is restartedp) + (is (eq (sym "BAR" "SYM") + (sym "BAZ" "SYM")))))) + +(with-test (:name export.ensure-exported) + (with-packages (("FOO" (:intern "SYM")) + ("BAR" (:export "SYM")) + ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM"))) + (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp) + (export (sym "FOO" "SYM") "FOO") + (is restartedp) + (is (equal (list (sym "FOO" "SYM") :external) + (multiple-value-list (sym "FOO" "SYM")))) + (is (eq (sym "FOO" "SYM") + (sym "BAZ" "SYM")))))) + +(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) + (export (sym "FOO" "SYM") "FOO") + (is restartedp) + (is (eq (sym "FOO" "SYM") + (sym "BAZ" "SYM")))))) + +(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) + (export (sym "FOO" "SYM") "FOO") + (is restartedp) + (is (equal (list (sym "BAZ" "SYM") :internal) + (multiple-value-list (sym "BAZ" "SYM"))))))) + +;;; IMPORT +(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) + (import (list (sym "FOO" "NIL")) "BAZ") + (is restartedp) + (is (eq (sym "FOO" "NIL") + (sym "BAZ" "NIL")))))) + +(with-test (:name import-nil.2) + (with-packages (("BAZ" (:use) (:intern "NIL"))) + (with-name-conflict-resolution ('CL:NIL :restarted restartedp) + (import '(CL:NIL) "BAZ") + (is restartedp) + (is (eq 'CL:NIL + (sym "BAZ" "NIL")))))) + +(with-test (:name import-single-conflict :fails-on :sbcl) + (with-packages (("FOO" (:export "NIL")) + ("BAR" (:export "NIL")) + ("BAZ" (:use))) + (let ((conflict-sets '())) + (handler-bind + ((sb-ext:name-conflict + (lambda (condition) + (push (copy-list (sb-ext:name-conflict-symbols condition)) + conflict-sets) + (invoke-restart 'sb-ext:resolve-conflict 'CL:NIL)))) + (import (list 'CL:NIL (sym "FOO" "NIL") (sym "BAR" "NIL")) "BAZ")) + (is (eql 1 (length conflict-sets))) + (is (eql 3 (length (first conflict-sets))))))) + +;;; UNINTERN +(with-test (:name unintern.1) + (with-packages (("FOO" (:export "SYM")) + ("BAR" (:export "SYM")) + ("BAZ" (:use "FOO" "BAR") (:shadow "SYM"))) + (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp) + (unintern (sym "BAZ" "SYM") "BAZ") + (is restartedp) + (is (eq (sym "FOO" "SYM") + (sym "BAZ" "SYM")))))) diff --git a/version.lisp-expr b/version.lisp-expr index 832115e..27133ca 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.19.14" +"1.0.19.15" -- 1.7.10.4