From: Christophe Rhodes Date: Tue, 16 Aug 2005 13:46:59 +0000 (+0000) Subject: 0.9.3.57: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=sidebyside;h=935cb138f2973da3293564c57c47e2194ce27cf5;p=sbcl.git 0.9.3.57: Fix CALL-NEXT-METHOD.[12] (PFD ansi-tests) ... partly from fix for CMUCL by Gerd Moellmann (sometime in 2003 I think) ... use macroexpansion environment rather than extra compiler support to determine whether to elide the check. --- diff --git a/NEWS b/NEWS index c60aeda..ee4eb10 100644 --- a/NEWS +++ b/NEWS @@ -42,6 +42,10 @@ changes in sbcl-0.9.4 relative to sbcl-0.9.3: ** bug fix: lockup when compiled with gcc4 ** bug fix: race that allows the gc to be triggered when gc is inhibited + * fixed some bugs revealed by Paul Dietz' test suite: + ** CALL-NEXT-METHOD signals an error (in safe code) when the call + has arguments with a different set of applicable methods from + the orignal arguments. changes in sbcl-0.9.3 relative to sbcl-0.9.2: * New feature: Experimental support for bivalent streams: streams diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 8cc6e51..10edc78 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -818,6 +818,10 @@ bootstrapping. (,',next-methods (cdr ,',next-methods))) .next-method. ,',next-methods ,@body)) + (check-cnm-args-body (&environment env method-name-declaration cnm-args) + (if (safe-code-p env) + `(%check-cnm-args ,cnm-args ,',method-args ',method-name-declaration) + nil)) (call-next-method-body (method-name-declaration cnm-args) `(if .next-method. (funcall (if (std-instance-p .next-method.) @@ -1062,7 +1066,8 @@ bootstrapping. (apply emf args)))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) - &body body) + &body body + &environment env) (let* ((all-params (append args (when rest-arg (list rest-arg)))) (rebindings (mapcar (lambda (x) (list x x)) all-params))) `(macrolet ((narrowed-emf (emf) @@ -1093,6 +1098,11 @@ bootstrapping. ,emf)) (call-next-method-bind (&body body) `(let () ,@body)) + (check-cnm-args-body (&environment env method-name-declaration cnm-args) + (if (safe-code-p env) + `(%check-cnm-args ,cnm-args (list ,@',args) + ',method-name-declaration) + nil)) (call-next-method-body (method-name-declaration cnm-args) `(if ,',next-method-call ,(locally @@ -1155,15 +1165,42 @@ bootstrapping. `(call-next-method-bind (flet (,@(and call-next-method-p `((call-next-method (&rest cnm-args) - (call-next-method-body - ,method-name-declaration - cnm-args)))) + (check-cnm-args-body ,method-name-declaration cnm-args) + (call-next-method-body ,method-name-declaration cnm-args)))) ,@(and next-method-p-p '((next-method-p () (next-method-p-body))))) (with-rebound-original-args (,call-next-method-p ,setq-p) ,@body)))))) +;;; CMUCL comment (Gerd Moellmann): +;;; +;;; The standard says it's an error if CALL-NEXT-METHOD is called with +;;; arguments, and the set of methods applicable to those arguments is +;;; different from the set of methods applicable to the original +;;; method arguments. (According to Barry Margolin, this rule was +;;; probably added to ensure that before and around methods are always +;;; run before primary methods.) +;;; +;;; This could be optimized for the case that the generic function +;;; doesn't have hairy methods, does have standard method combination, +;;; is a standard generic function, there are no methods defined on it +;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such +;;; preconditions. That looks hairy and is probably not worth it, +;;; because this check will never be fast. +(defun %check-cnm-args (cnm-args orig-args method-name-declaration) + (when cnm-args + (let* ((gf (fdefinition (caar method-name-declaration))) + (omethods (compute-applicable-methods gf orig-args)) + (nmethods (compute-applicable-methods gf cnm-args))) + (unless (equal omethods nmethods) + (error "~@" + nmethods (length cnm-args) cnm-args omethods + (length orig-args) orig-args))))) + (defmacro bind-args ((lambda-list args) &body body) (let ((args-tail '.args-tail.) (key '.key.) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index f475943..3fe2083 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -47,6 +47,11 @@ (t `(typep (layout-of object) 'sb-pcl::wrapper))))) +(defun sb-pcl::safe-code-p (&optional env) + (let* ((lexenv (or env (make-null-lexenv))) + (policy (lexenv-policy lexenv))) + (eql (cdr (assoc 'safety policy)) 3))) + (define-source-context defmethod (name &rest stuff) (let ((arg-pos (position-if #'listp stuff))) (if arg-pos diff --git a/version.lisp-expr b/version.lisp-expr index 25fe9cc..3d34f2d 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.9.3.56" +"0.9.3.57"