From 1ecb2d07a7a3c0964d473c1eca66cebd4223e47a Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Tue, 29 Jan 2013 11:27:34 +0200
Subject: [PATCH] nicer name-conflict restarts for common cases

  For IMPORT: offer option to SHADOWING-IMPORT the new symbol or skip
  importing.

  For EXPORT: offer option to KEEP-OLD or TAKE-NEW. (Shadowing or
  uninterning the other one.)

  For USE-PACKAGE: offer option to KEEP-OLD or TAKE-NEW. (Shadowing or
  uninterning the other ones.)
---
 src/code/target-package.lisp |  145 ++++++++++++++++++++++++++++--------------
 tests/packages.impure.lisp   |   84 ++++++++++++++++++++++++
 2 files changed, 182 insertions(+), 47 deletions(-)

diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index 00cbc54..892ceaf 100644
--- a/src/code/target-package.lisp
+++ b/src/code/target-package.lisp
@@ -894,56 +894,107 @@ implementation it is ~S." *default-package-use-list*)
              (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 (chosen-symbol)
-      :report "Resolve conflict."
-      :interactive
-      (lambda ()
-        (let* ((len (length symbols))
-               (nlen (length (write-to-string len :base 10)))
-               (*print-pretty* t))
-          (format *query-io* "~&~@<Select a symbol to be made accessible in ~
+  (flet ((importp (c)
+           (declare (ignore c))
+           (eq 'import function))
+         (use-or-export-p (c)
+           (declare (ignore c))
+           (or (eq 'use-package function)
+               (eq 'export function)))
+         (old-symbol ()
+           (car (remove datum symbols))))
+    (let ((pname (package-name package)))
+      (restart-case
+          (error 'name-conflict :package package :symbols symbols
+                                :function function :datum datum)
+        ;; USE-PACKAGE and EXPORT
+        (keep-old ()
+          :report (lambda (s)
+                    (ecase function
+                      (export
+                       (format s "Keep ~S accessible in ~A (shadowing ~S)."
+                               (old-symbol) pname datum))
+                      (use-package
+                       (format s "Keep symbols already accessible ~A (shadowing others)."
+                               pname))))
+          :test use-or-export-p
+          (dolist (s (remove-duplicates symbols :test #'string=))
+            (shadow (symbol-name s) package)))
+        (take-new ()
+          :report (lambda (s)
+                    (ecase function
+                      (export
+                       (format s "Make ~S accessible in ~A (uninterning ~S)."
+                               datum pname (old-symbol)))
+                      (use-package
+                       (format s "Make newly exposed symbols accessible in ~A, ~
+                                  uninterning old ones."
+                               pname))))
+          :test use-or-export-p
+          (dolist (s symbols)
+            (when (eq s (find-symbol (symbol-name s) package))
+              (unintern s package))))
+        ;; IMPORT
+        (shadowing-import-it ()
+          :report (lambda (s)
+                    (format s "Shadowing-import ~S, uninterning ~S."
+                            datum (old-symbol)))
+          :test importp
+          (shadowing-import datum package))
+        (dont-import-it ()
+          :report (lambda (s)
+                    (format s "Don't import ~S, keeping ~S."
+                            datum
+                            (car (remove datum symbols))))
+          :test importp)
+        ;; General case. This is exposed via SB-EXT.
+        (resolve-conflict (chosen-symbol)
+          :report "Resolve conflict."
+          :interactive
+          (lambda ()
+            (let* ((len (length symbols))
+                   (nlen (length (write-to-string len :base 10)))
+                   (*print-pretty* t))
+              (format *query-io* "~&~@<Select a symbol to be made accessible in ~
                               package ~A:~2I~@:_~{~{~V,' D. ~
                               ~/sb-impl::print-symbol-with-prefix/~}~@:_~}~
                               ~@:>"
-                (package-name package)
-                (loop for s in symbols
-                      for i upfrom 1
-                      collect (list nlen i s)))
-          (loop
-           (format *query-io* "~&Enter an integer (between 1 and ~D): " len)
-           (finish-output *query-io*)
-           (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 (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 (list chosen-symbol) package)))))))))
+                      (package-name package)
+                      (loop for s in symbols
+                            for i upfrom 1
+                            collect (list nlen i s)))
+              (loop
+                (format *query-io* "~&Enter an integer (between 1 and ~D): " len)
+                (finish-output *query-io*)
+                (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 (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 (list chosen-symbol) package)))))))))))
 
 ;;; If we are uninterning a shadowing symbol, then a name conflict can
 ;;; result, otherwise just nuke the symbol.
diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp
index 0e78218..31046f5 100644
--- a/tests/packages.impure.lisp
+++ b/tests/packages.impure.lisp
@@ -304,3 +304,87 @@ if a restart was invoked."
     (with-timeout 10
       (assert (eq 'cons (read-from-string "CL:CONS"))))
     (sb-thread:signal-semaphore sem2)))
+
+(with-test (:name :quick-name-conflict-resolution-import)
+  (let (p1 p2)
+    (unwind-protect
+         (progn
+           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1")
+                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2"))
+           (intern "FOO" p1)
+           (handler-bind ((name-conflict (lambda (c)
+                                           (invoke-restart 'sb-impl::dont-import-it))))
+             (import (intern "FOO" p2) p1))
+           (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
+           (handler-bind ((name-conflict (lambda (c)
+                                           (invoke-restart 'sb-impl::shadowing-import-it))))
+             (import (intern "FOO" p2) p1))
+           (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
+      (when p1 (delete-package p1))
+      (when p2 (delete-package p2)))))
+
+(with-test (:name :quick-name-conflict-resolution-export.1)
+  (let (p1 p2)
+    (unwind-protect
+         (progn
+           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a")
+                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a"))
+           (intern "FOO" p1)
+           (use-package p2 p1)
+           (handler-bind ((name-conflict (lambda (c)
+                                           (invoke-restart 'sb-impl::keep-old))))
+             (export (intern "FOO" p2) p2))
+           (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))))
+      (when p1 (delete-package p1))
+      (when p2 (delete-package p2)))))
+
+(with-test (:name :quick-name-conflict-resolution-export.2)
+  (let (p1 p2)
+    (unwind-protect
+         (progn
+           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b")
+                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b"))
+           (intern "FOO" p1)
+           (use-package p2 p1)
+           (handler-bind ((name-conflict (lambda (c)
+                                           (invoke-restart 'sb-impl::take-new))))
+             (export (intern "FOO" p2) p2))
+           (assert (eq (intern "FOO" p1) (intern "FOO" p2))))
+      (when p1 (delete-package p1))
+      (when p2 (delete-package p2)))))
+
+(with-test (:name :quick-name-conflict-resolution-use-package.1)
+  (let (p1 p2)
+    (unwind-protect
+         (progn
+           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a")
+                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a"))
+           (intern "FOO" p1)
+           (intern "BAR" p1)
+           (export (intern "FOO" p2) p2)
+           (export (intern "BAR" p2) p2)
+           (handler-bind ((name-conflict (lambda (c)
+                                           (invoke-restart 'sb-impl::keep-old))))
+             (use-package p2 p1))
+           (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))
+           (assert (not (eq (intern "BAR" p1) (intern "BAR" p2)))))
+      (when p1 (delete-package p1))
+      (when p2 (delete-package p2)))))
+
+(with-test (:name :quick-name-conflict-resolution-use-package.2)
+  (let (p1 p2)
+    (unwind-protect
+         (progn
+           (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b")
+                 p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b"))
+           (intern "FOO" p1)
+           (intern "BAR" p1)
+           (export (intern "FOO" p2) p2)
+           (export (intern "BAR" p2) p2)
+           (handler-bind ((name-conflict (lambda (c)
+                                           (invoke-restart 'sb-impl::take-new))))
+             (use-package p2 p1))
+           (assert (eq (intern "FOO" p1) (intern "FOO" p2)))
+           (assert (eq (intern "BAR" p1) (intern "BAR" p2))))
+      (when p1 (delete-package p1))
+      (when p2 (delete-package p2)))))
-- 
1.7.10.4