- (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* "~&~@<Select a symbol to be made accessible in ~
- package ~A:~2I~@:_~{~{~V,' D. ~S~}~@:_~}~@:>"
- (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))))))
+ (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)))))))))))