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)

diff --git a/NEWS b/NEWS
index d453f74..6c011bd 100644 (file)
--- 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 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -308,18 +308,48 @@ bootstrapping.
       ;; belong here!
       (aver (not morep)))))
 \f
-(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 (file)
--- 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)))
+\f
+;;; 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 (file)
--- 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 (file)
--- 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"