Changeset 13207

Timestamp:

02/08/11 17:59:09 (12 years ago)

Author:

ehuelsmann

Message:

Fix CHECK-INITARGS checking the wrong generic functions by
making it general purpose and ask for more parameters.

File:

• trunk/abcl/src/org/armedbear/lisp/clos.lisp (modified) (7 diffs)

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -691 +691 @@
   (declare (ignore metaclass))
   (let ((class (std-allocate-instance +the-standard-class+)))
-    (check-initargs class t initargs)
+    (check-initargs (list #'allocate-instance #'initialize-instance)
+                    (list* class initargs)
+                    class t initargs)
     (%set-class-name name class)
     (%set-class-layout nil class)
@@ -788 +790 @@
                   (%make-instances-obsolete old-class)
                   (setf (class-finalized-p old-class) nil)
-                  (check-initargs old-class t all-keys)
+                  (check-initargs (list #'allocate-instance #'initialize-instance)
+                                  (list* old-class all-keys)
+                                  old-class t all-keys)
                   (apply #'std-after-initialization-for-classes old-class all-keys)
                   old-class)))
@@ -2556 +2560 @@
 ;; 7.1.2
 
-(defun check-initargs (instance shared-initialize-param initargs)
+(defun check-initargs (gf-list args instance shared-initialize-param initargs)
   (when (oddp (length initargs))
     (error 'program-error
@@ -2566 +2570 @@
                                         (list* instance shared-initialize-param
                                                initargs))
-            (compute-applicable-methods #'initialize-instance
-                                        (list* instance initargs))))
+            (mapcan #'(lambda (gf)
+                        (compute-applicable-methods gf args))
+                    gf-list)))
           (slots (class-slots (class-of instance))))
       (do* ((tail initargs (cddr tail))
@@ -2618 +2623 @@
 
   (let ((instance (std-allocate-instance class)))
-    (check-initargs instance t initargs)
+    (check-initargs (list #'allocate-instance #'initialize-instance)
+                    (list* instance initargs)
+                    instance t initargs)
     (apply #'initialize-instance instance initargs)
     instance))
@@ -2724 +2731 @@
                     (mapcar 'slot-definition-name
                             (class-slots (class-of new))))))
-    (check-initargs new added-slots initargs)
+    (check-initargs (list #'update-instance-for-different-class)
+                    (list old new initargs)
+                    new added-slots initargs)
     (apply #'shared-initialize new added-slots initargs)))
 
@@ -2753 +2762 @@
             property-list
             &rest initargs)
-  (check-initargs instance added-slots initargs)
+  (check-initargs (list #'update-instance-for-redefined-class)
+                  (list* instance added-slots discarded-slots
+                         property-list initargs)
+                  instance added-slots initargs)
   (apply #'shared-initialize instance added-slots initargs))