[armedbear-cvs] r14348 - branches/1.1.x/src/org/armedbear/lisp

[mevenson at common-lisp.net]

Author: mevenson
Date: Sat Jan  5 23:45:29 2013
New Revision: 14348

Log:
Backport r14347 | rschlatte | 2013-01-05 19:39:28 +0100 (Sat, 05 Jan 2013) | 3 lines

defer checking for lambda list congruence.

- fixes #284

Modified:
   branches/1.1.x/src/org/armedbear/lisp/clos.lisp

Modified: branches/1.1.x/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- branches/1.1.x/src/org/armedbear/lisp/clos.lisp	Sat Jan  5 10:39:28 2013	(r14347)
+++ branches/1.1.x/src/org/armedbear/lisp/clos.lisp	Sat Jan  5 23:45:29 2013	(r14348)
@@ -3970,6 +3970,17 @@
                                          &rest all-keys)
   (apply #'std-after-reinitialization-for-classes class all-keys))
 
+(defmethod reinitialize-instance :before ((gf standard-generic-function)
+                                          &key
+                                            (lambda-list nil lambda-list-supplied-p)
+                                          &allow-other-keys)
+  (when lambda-list-supplied-p
+    (unless (or (null (generic-function-methods gf))
+                (lambda-lists-congruent-p lambda-list
+                                          (generic-function-lambda-list gf)))
+      (error "The lambda list ~S is incompatible with the existing methods of ~S."
+             lambda-list gf))))
+
 (defmethod reinitialize-instance :after ((gf standard-generic-function)
                                          &rest all-keys)
   (map-dependents gf #'(lambda (dep) (update-dependent gf dep all-keys))))
@@ -4558,7 +4569,6 @@
      function-name
      &rest all-keys
      &key (generic-function-class (class-of generic-function))
-     (lambda-list nil lambda-list-supplied-p)
      (method-class (generic-function-method-class generic-function))
      (method-combination (generic-function-method-combination generic-function))
      &allow-other-keys)
@@ -4570,16 +4580,10 @@
   (unless (eq generic-function-class (class-of generic-function))
     (error "The class ~S is incompatible with the existing class (~S) of ~S."
            generic-function-class (class-of generic-function) generic-function))
-  (when lambda-list-supplied-p
-    (unless (or (null (generic-function-methods generic-function))
-                (lambda-lists-congruent-p lambda-list
-                                          (generic-function-lambda-list generic-function)))
-      (error "The lambda list ~S is incompatible with the existing methods of ~S."
-             lambda-list generic-function)))
-  (unless (or (null (generic-function-methods generic-function))
-              (eq method-class (generic-function-method-class generic-function)))
-    (error "The method class ~S is incompatible with the existing methods of ~S."
-           method-class generic-function))
+  ;; We used to check for changes in method class here, but CLHS says:
+  ;; "If function-name specifies a generic function that has a different
+  ;; value for the :method-class argument, the value is changed, but any
+  ;; existing methods are not changed."
   (unless (typep method-combination 'method-combination)
     (setf method-combination
           (find-method-combination generic-function