+(defun print-symbol-with-prefix (stream symbol colon at)
+ #!+sb-doc
+ "For use with ~/: Write SYMBOL to STREAM as if it is not accessible from
+ the current package."
+ (declare (ignore colon at))
+ ;; Only keywords should be accessible from the keyword package, and
+ ;; keywords are always printed with colons, so this guarantees that the
+ ;; symbol will not be printed without a prefix.
+ (let ((*package* *keyword-package*))
+ (write symbol :stream stream :escape t)))
+
+(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~@:_~
+ ~{~/sb-impl::print-symbol-with-prefix/~^, ~}~:@>"
+ (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)))
+ (*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 (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))))))
+