[armedbear-cvs] r14344 - trunk/abcl/src/org/armedbear/lisp

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Sun Dec 30 09:09:06 2012
New Revision: 14344

Log:
Avoid premature initialization of method-class, method-combination in gfs

- fixes #279

- reported by Pascal Costanza

Modified:
   trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sun Dec 23 08:46:01 2012	(r14343)
+++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java	Sun Dec 30 09:09:06 2012	(r14344)
@@ -61,7 +61,7 @@
     slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] =
       StandardClass.STANDARD_METHOD;
     slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] =
-      Symbol.STANDARD; // fixed up by shared-initialize :after in clos.lisp
+      list(Symbol.STANDARD); // fixed up by clos.lisp:shared-initialize :after
     slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
       NIL;
     slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL;

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Dec 23 08:46:01 2012	(r14343)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Dec 30 09:09:06 2012	(r14344)
@@ -1825,8 +1825,8 @@
 
 (defun make-instance-standard-generic-function (generic-function-class
                                                 &key name lambda-list
-                                                method-class
-                                                method-combination
+                                                (method-class +the-standard-method-class+)
+                                                (method-combination +the-standard-method-combination+)
                                                 argument-precedence-order
                                                 declarations
                                                 documentation)
@@ -1834,6 +1834,11 @@
   (declare (ignore generic-function-class))
   (check-argument-precedence-order lambda-list argument-precedence-order)
   (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
+    (unless (classp method-class) (setf method-class (find-class method-class)))
+    (unless (typep method-combination 'method-combination)
+      (setf method-combination
+            (find-method-combination
+             gf (car method-combination) (cdr method-combination))))
     (%set-generic-function-name gf name)
     (%set-generic-function-lambda-list gf lambda-list)
     (set-generic-function-initial-methods gf ())
@@ -4370,6 +4375,7 @@
 (defmethod shared-initialize :after ((instance standard-generic-function)
                                      slot-names
                                      &key lambda-list argument-precedence-order
+                                       (method-combination '(standard))
                                      &allow-other-keys)
   (let* ((plist (analyze-lambda-list lambda-list))
          (required-args (getf plist ':required-args)))
@@ -4377,11 +4383,13 @@
     (%set-gf-optional-args instance (getf plist :optional-args))
     (set-generic-function-argument-precedence-order
      instance (or argument-precedence-order required-args)))
-  (when (eq (generic-function-method-combination instance) 'standard)
-    ;; fix up "naked" (make-instance 'standard-generic-function) -- gfs
-    ;; created via defgeneric have that slot initalized properly
-    (set-generic-function-method-combination instance
-                                             +the-standard-method-combination+))
+  (unless (typep (generic-function-method-combination instance)
+                 'method-combination)
+    ;; this fixes (make-instance 'standard-generic-function) -- the
+    ;; constructor of StandardGenericFunction sets this slot to '(standard)
+    (setf (generic-function-method-combination instance)
+          (find-method-combination
+           instance (car method-combination) (cdr method-combination))))
   (finalize-standard-generic-function instance))
 
 ;;; Readers for generic function metaobjects
@@ -4587,19 +4595,11 @@
                                                 function-name
                                                 &rest all-keys
                                                 &key (generic-function-class +the-standard-generic-function-class+)
-                                                  (method-class +the-standard-method-class+)
-                                                  (method-combination +the-standard-method-combination+)
                                                 &allow-other-keys)
   (setf all-keys (copy-list all-keys))  ; since we modify it
   (remf all-keys :generic-function-class)
   (unless (classp generic-function-class)
     (setf generic-function-class (find-class generic-function-class)))
-  (unless (classp method-class) (setf method-class (find-class method-class)))
-  (unless (typep method-combination 'method-combination)
-    (setf method-combination
-          (find-method-combination (class-prototype generic-function-class)
-                                   (car method-combination)
-                                   (cdr method-combination))))
   (when (and (null *clos-booting*) (fboundp function-name))
     (if (autoloadp function-name)
         (fmakunbound function-name)
@@ -4609,11 +4609,7 @@
   (apply (if (eq generic-function-class +the-standard-generic-function-class+)
              #'make-instance-standard-generic-function
              #'make-instance)
-         generic-function-class
-         :name function-name
-         :method-class method-class
-         :method-combination method-combination
-         all-keys))
+         generic-function-class :name function-name all-keys))
 
 (defun ensure-generic-function (function-name &rest all-keys
                                 &key