Changeset 14345

Timestamp:

12/31/12 10:21:17 (10 years ago)

Author:

Mark Evenson

Message:

Backport r14344 | rschlatte | 2012-12-30 18:09:06 +0100 (Sun, 30 Dec 2012) | 5 lines

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

• fixes #279

• reported by Pascal Costanza

Location:

branches/1.1.x/src/org/armedbear/lisp

Files:

• StandardGenericFunction.java (modified) (1 diff)
• clos.lisp (modified) (7 diffs)

branches/1.1.x/src/org/armedbear/lisp/StandardGenericFunction.java

@@ -62 +62 @@
       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;

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

@@ -1826 +1826 @@
 (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
@@ -1835 +1835 @@
   (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)
@@ -4371 +4376 @@
                                      slot-names
                                      &key lambda-list argument-precedence-order
+                                       (method-combination '(standard))
                                      &allow-other-keys)
   (let* ((plist (analyze-lambda-list lambda-list))
@@ -4378 +4384 @@
     (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))
 
@@ -4588 +4596 @@
                                                 &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
@@ -4595 +4601 @@
   (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)
@@ -4610 +4610 @@
              #'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