From 76e5ccc7e653ffe279148bb8f3f6f5b7c4772a4e Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 17 Jul 2007 11:24:26 +0000 Subject: [PATCH] 1.0.7.24: Fix CALL-NEXT-METHOD / EVAL-WHEN interaction Reported by Sascha Wilde sbcl-devel 2007-07-15. This fix is not the one that I sent to sbcl-devel 2007-07-16, because that's just too horrible; instead we expand DEFMETHOD into separate :LOAD-TOPLEVEL and :EXECUTE branches. (This needs a minor test adjustment) --- NEWS | 4 ++++ src/pcl/boot.lisp | 50 +++++++++++++++++++++++++++++++++--------- tests/clos.impure-cload.lisp | 7 ++++++ tests/clos.impure.lisp | 6 ++--- version.lisp-expr | 2 +- 5 files changed, 54 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index d453f74..6c011bd 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,10 @@ changes in sbcl-1.0.8 relative to sbcl-1.0.7: thread safe. * bug fix: (SETF SYMBOL-PLIST) no longer allows assigning a non-list as the property-list of a symbol. + * bug fix: DEFMETHOD forms with CALL-NEXT-METHOD in the method body, + in EVAL-WHEN forms with both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL + situations requested, are once again file-compileable. (reported + by Sascha Wilde) changes in sbcl-1.0.7 relative to sbcl-1.0.6: * MOP improvement: support for user-defined subclasses of diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 526229f..8f3a2da 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -308,18 +308,48 @@ bootstrapping. ;; belong here! (aver (not morep))))) -(defmacro defmethod (&rest args &environment env) +(defmacro defmethod (&rest args) (multiple-value-bind (name qualifiers lambda-list body) (parse-defmethod args) - (multiple-value-bind (proto-gf proto-method) - (prototypes-for-make-method-lambda name) - (expand-defmethod name - proto-gf - proto-method - qualifiers - lambda-list - body - env)))) + `(progn + ;; KLUDGE: this double expansion is quite a monumental + ;; workaround: it comes about because of a fantastic interaction + ;; between the processing rules of CLHS 3.2.3.1 and the + ;; bizarreness of MAKE-METHOD-LAMBDA. + ;; + ;; MAKE-METHOD-LAMBDA can be called by the user, and if the + ;; lambda itself doesn't refer to outside bindings the return + ;; value must be compileable in the null lexical environment. + ;; However, the function must also refer somehow to the + ;; associated method object, so that it can call NO-NEXT-METHOD + ;; with the appropriate arguments if there is no next method -- + ;; but when the function is generated, the method object doesn't + ;; exist yet. + ;; + ;; In order to resolve this issue, we insert a literal cons cell + ;; into the body of the method lambda, return the same cons cell + ;; as part of the second (initargs) return value of + ;; MAKE-METHOD-LAMBDA, and a method on INITIALIZE-INSTANCE fills + ;; in the cell when the method is created. However, this + ;; strategy depends on having a fresh cons cell for every method + ;; lambda, which (without the workaround below) is skewered by + ;; the processing in CLHS 3.2.3.1, which permits implementations + ;; to macroexpand the bodies of EVAL-WHEN forms with both + ;; :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL only once. The + ;; expansion below forces the double expansion in those cases, + ;; while expanding only once in the common case. + (eval-when (:load-toplevel) + (%defmethod-expander ,name ,qualifiers ,lambda-list ,body)) + (eval-when (:execute) + (%defmethod-expander ,name ,qualifiers ,lambda-list ,body))))) + +(defmacro %defmethod-expander + (name qualifiers lambda-list body &environment env) + (multiple-value-bind (proto-gf proto-method) + (prototypes-for-make-method-lambda name) + (expand-defmethod name proto-gf proto-method qualifiers + lambda-list body env))) + (defun prototypes-for-make-method-lambda (name) (if (not (eq *boot-state* 'complete)) diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp index 2353a74..d5d8c30 100644 --- a/tests/clos.impure-cload.lisp +++ b/tests/clos.impure-cload.lisp @@ -177,3 +177,10 @@ (assert (typep (ctor-literal-class) 'ctor-literal-class))) (with-test (:name (:ctor :literal-class-quoted)) (assert (typep (ctor-literal-class2) 'ctor-literal-class2))) + +;;; test that call-next-method and eval-when doesn't cause an +;;; undumpable method object to arise in the effective source code. +;;; (from Sascha Wilde sbcl-devel 2007-07-15) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmethod just-call-next-method (thing) + (call-next-method))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 4994d55..47ad924 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -61,9 +61,7 @@ (ignore-errors (progn ,@body)) (declare (ignore res)) (typep condition 'error)))) -(assert (expect-error - (macroexpand-1 - '(defmethod foo0 ((x t) &rest) nil)))) +(assert (expect-error (defmethod foo0 ((x t) &rest) nil))) (assert (expect-error (defgeneric foo1 (x &rest)))) (assert (expect-error (defgeneric foo2 (x a &rest)))) (defgeneric foo3 (x &rest y)) @@ -71,7 +69,7 @@ (defmethod foo4 ((x t) &rest z &key y) nil) (defgeneric foo4 (x &rest z &key y)) (assert (expect-error (defgeneric foo5 (x &rest)))) -(assert (expect-error (macroexpand-1 '(defmethod foo6 (x &rest))))) +(assert (expect-error (defmethod foo6 (x &rest)))) ;;; more lambda-list checking ;;; diff --git a/version.lisp-expr b/version.lisp-expr index f2cea43..a940c83 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".) -"1.0.7.23" +"1.0.7.24" -- 1.7.10.4