* 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.
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*;
(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 ()
(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.
(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)
(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 ()))
(cl:defpackage "ASSERTOID"
(:use "CL")
- (:export "GRAB-CONDITION" "RAISES-ERROR?" "ASSERTOID"))
+ (:export "GRAB-CONDITION" "RAISES-ERROR?" "IS" "ASSERTOID"))
(cl:in-package "ASSERTOID")
;;; 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))))
(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"))))))
;;; 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"
projects / sbcl.git / commitdiff