From 967a23111b5c6e7d457d879dea546ace812fc962 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sat, 16 Apr 2005 10:02:38 +0000 Subject: [PATCH] 0.8.21.47: Merge patch (from Wendall Marvel) for unchecked method group when there is a single group with pattern * --- NEWS | 3 ++ src/pcl/defcombin.lisp | 122 +++++++++++++++++++++++++++--------------------- tests/clos.impure.lisp | 114 ++++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 186 insertions(+), 55 deletions(-) diff --git a/NEWS b/NEWS index d5d7f50..3a0acf1 100644 --- a/NEWS +++ b/NEWS @@ -53,6 +53,9 @@ changes in sbcl-0.8.22 relative to sbcl-0.8.21: * bug fix: redefining a class definition which failed due to a previous accessor / function clash now works (but see BUGS entry #380 for more problems in this area). (thanks to Zach Beane) + * the long form of DEFINE-METHOD-COMBINATION disables method group + checking when given a single method group with pattern *. (thanks + to Wendall Marvel) * on x86 compiler supports stack allocation of results of simple calls of MAKE-ARRAY, bound to variables, declared DYNAMIC-EXTENT. * fixed some bugs related to Unicode integration: diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 060f4a0..44f8fdb 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -299,68 +299,82 @@ .method-combination. .applicable-methods.)) (block .long-method-combination-function. ,wrapped-body)))))) -;; parse-method-group-specifiers parse the method-group-specifiers - (define-condition long-method-combination-error (reference-condition simple-error) () (:default-initargs :references (list '(:ansi-cl :macro define-method-combination)))) +;;; NOTE: +;;; +;;; The semantics of long form method combination in the presence of +;;; multiple methods with the same specializers in the same method +;;; group are unclear by the spec: a portion of the standard implies +;;; that an error should be signalled, and another is more lenient. +;;; +;;; It is reasonable to allow a single method group of * to bypass all +;;; rules, as this is explicitly stated in the standard. + +(defun group-cond-clause (name tests specializer-cache star-only) + (let ((maybe-error-clause + (if star-only + `(setq ,specializer-cache .specializers.) + `(if (and (equal ,specializer-cache .specializers.) + (not (null .specializers.))) + (return-from .long-method-combination-function. + '(error 'long-method-combination-error + :format-control "More than one method of type ~S ~ + with the same specializers." + :format-arguments (list ',name))) + (setq ,specializer-cache .specializers.))))) + `((or ,@tests) + ,maybe-error-clause + (push .method. ,name)))) + (defun wrap-method-group-specifier-bindings - (method-group-specifiers declarations real-body) - (let (names - specializer-caches - cond-clauses - required-checks - order-cleanups) + (method-group-specifiers declarations real-body) + (let (names specializer-caches cond-clauses required-checks order-cleanups) + (let ((nspecifiers (length method-group-specifiers))) (dolist (method-group-specifier method-group-specifiers) - (multiple-value-bind (name tests description order required) - (parse-method-group-specifier method-group-specifier) - (declare (ignore description)) - (let ((specializer-cache (gensym))) - (push name names) - (push specializer-cache specializer-caches) - (push `((or ,@tests) - (if (and (equal ,specializer-cache .specializers.) - (not (null .specializers.))) - (return-from .long-method-combination-function. - '(error 'long-method-combination-error - :format-control "More than one method of type ~S ~ - with the same specializers." - :format-arguments (list ',name))) - (setq ,specializer-cache .specializers.)) - (push .method. ,name)) - cond-clauses) - (when required - (push `(when (null ,name) - (return-from .long-method-combination-function. - '(error 'long-method-combination-error - :format-control "No ~S methods." - :format-arguments (list ',name)))) - required-checks)) - (loop (unless (and (constantp order) - (neq order (setq order (eval order)))) - (return t))) - (push (cond ((eq order :most-specific-first) - `(setq ,name (nreverse ,name))) - ((eq order :most-specific-last) ()) - (t - `(ecase ,order - (:most-specific-first - (setq ,name (nreverse ,name))) - (:most-specific-last)))) - order-cleanups)))) - `(let (,@(nreverse names) ,@(nreverse specializer-caches)) - ,@declarations - (dolist (.method. .applicable-methods.) - (let ((.qualifiers. (method-qualifiers .method.)) - (.specializers. (method-specializers .method.))) - (declare (ignorable .qualifiers. .specializers.)) - (cond ,@(nreverse cond-clauses)))) - ,@(nreverse required-checks) - ,@(nreverse order-cleanups) - ,@real-body))) + (multiple-value-bind (name tests description order required) + (parse-method-group-specifier method-group-specifier) + (declare (ignore description)) + (let ((specializer-cache (gensym))) + (push name names) + (push specializer-cache specializer-caches) + (push (group-cond-clause name tests specializer-cache + (and (eq (cadr method-group-specifier) '*) + (= nspecifiers 1))) + cond-clauses) + (when required + (push `(when (null ,name) + (return-from .long-method-combination-function. + '(error 'long-method-combination-error + :format-control "No ~S methods." + :format-arguments (list ',name)))) + required-checks)) + (loop (unless (and (constantp order) + (neq order (setq order (eval order)))) + (return t))) + (push (cond ((eq order :most-specific-first) + `(setq ,name (nreverse ,name))) + ((eq order :most-specific-last) ()) + (t + `(ecase ,order + (:most-specific-first + (setq ,name (nreverse ,name))) + (:most-specific-last)))) + order-cleanups)))) + `(let (,@(nreverse names) ,@(nreverse specializer-caches)) + ,@declarations + (dolist (.method. .applicable-methods.) + (let ((.qualifiers. (method-qualifiers .method.)) + (.specializers. (method-specializers .method.))) + (declare (ignorable .qualifiers. .specializers.)) + (cond ,@(nreverse cond-clauses)))) + ,@(nreverse required-checks) + ,@(nreverse order-cleanups) + ,@real-body)))) (defun parse-method-group-specifier (method-group-specifier) ;;(declare (values name tests description order required)) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 763ea83..3d5bb34 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -434,6 +434,120 @@ form))) 'dmc-test-return)) +;;; DEFINE-METHOD-COMBINATION should, according to the description in 7.7, +;;; allow you to do everything in the body forms yourself if you specify +;;; exactly one method group whose qualifier-pattern is * +;;; +;;; The specific language is: +;;; "The use of method group specifiers provides a convenient syntax to select +;;; methods, to divide them among the possible roles, and to perform the +;;; necessary error checking. It is possible to perform further filtering of +;;; methods in the body forms by using normal list-processing operations and +;;; the functions method-qualifiers and invalid-method-error. It is permissible +;;; to use setq on the variables named in the method group specifiers and to +;;; bind additional variables. It is also possible to bypass the method group +;;; specifier mechanism and do everything in the body forms. This is +;;; accomplished by writing a single method group with * as its only +;;; qualifier-pattern; the variable is then bound to a list of all of the +;;; applicable methods, in most-specific-first order." +(define-method-combination wam-test-method-combination-a () + ((all-methods *)) + (do ((methods all-methods (rest methods)) + (primary nil) + (around nil)) + ((null methods) + (let ((primary (nreverse primary)) + (around (nreverse around))) + (if primary + (let ((form (if (rest primary) + `(call-method ,(first primary) ,(rest primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) (,@(rest around) + (make-method ,form))) + form)) + `(make-method (error "No primary methods"))))) + (let* ((method (first methods)) + (qualifier (first (method-qualifiers method)))) + (cond + ((equal :around qualifier) + (push method around)) + ((null qualifier) + (push method primary)))))) + +(defgeneric wam-test-mc-a (val) + (:method-combination wam-test-method-combination-a)) +(assert (raises-error? (wam-test-mc-a 13))) +(defmethod wam-test-mc-a ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) +(assert (= (wam-test-mc-a 13) 13)) +(defmethod wam-test-mc-a :around ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) +(assert (= (wam-test-mc-a 13) 26)) + +;;; DEFINE-METHOD-COMBINATION +;;; When two methods are in the same method group and have the same +;;; specializers, their sort order within the group may be ambiguous. Therefore, +;;; we should throw an error when we have two methods in the same group with +;;; the same specializers /as long as/ we have more than one method group +;;; or our single method group qualifier-pattern is not *. This resolves the +;;; apparent conflict with the above 'It is also possible to bypass' language. +;;; +;;; The language specifying this behavior is: +;;; "Note that two methods with identical specializers, but with different +;;; qualifiers, are not ordered by the algorithm described in Step 2 of the +;;; method selection and combination process described in Section 7.6.6 +;;; (Method Selection and Combination). Normally the two methods play different +;;; roles in the effective method because they have different qualifiers, and +;;; no matter how they are ordered in the result of Step 2, the effective +;;; method is the same. If the two methods play the same role and their order +;;; matters, an error is signaled. This happens as part of the qualifier +;;; pattern matching in define-method-combination." +;;; +;;; Note that the spec pretty much equates 'method group' and 'role'. +;; First we ensure that it fails correctly when there is more than one +;; method group +(define-method-combination wam-test-method-combination-b () + ((around (:around)) + (primary * :required t)) + (let ((form (if (rest primary) + `(call-method ,(first primary) ,(rest primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) (,@(rest around) + (make-method ,form))) + form))) + +(defgeneric wam-test-mc-b (val) + (:method-combination wam-test-method-combination-b)) +(defmethod wam-test-mc-b ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) +(assert (= (wam-test-mc-b 13) 13)) +(defmethod wam-test-mc-b :around ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) +(assert (= (wam-test-mc-b 13) 26)) +(defmethod wam-test-mc-b :somethingelse ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) +(assert (raises-error? (wam-test-mc-b 13))) + +;;; now, ensure that it fails with a single group with a qualifier-pattern +;;; that is not * +(define-method-combination wam-test-method-combination-c () + ((methods listp :required t)) + (if (rest methods) + `(call-method ,(first methods) ,(rest methods)) + `(call-method ,(first methods)))) + +(defgeneric wam-test-mc-c (val) + (:method-combination wam-test-method-combination-c)) +(assert (raises-error? (wam-test-mc-c 13))) +(defmethod wam-test-mc-c :foo ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) +(assert (= (wam-test-mc-c 13) 13)) +(defmethod wam-test-mc-c :bar ((val number)) + (+ val (if (next-method-p) (call-next-method) 0))) +(assert (raises-error? (wam-test-mc-c 13))) + ;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is ;;; given: (defmethod incompatible-ll-test-1 (x) x) diff --git a/version.lisp-expr b/version.lisp-expr index eeb1516..d3be083 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".) -"0.8.21.46" +"0.8.21.47" -- 1.7.10.4