Changeset 12067

Timestamp:

07/27/09 20:10:46 (14 years ago)

Author:

vvoutilainen

Message:

Better initarg checking. Fixes CHANGE-CLASS.1.11, MAKE-INSTANCE.ERROR.3 and MAKE-INSTANCE.ERROR.4.

File:

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

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

@@ -1970 +1970 @@
 ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
 ;; 7.1.2
-#+nil
-(defun check-initargs (class initargs)
+
+(defun check-initargs (instance shared-initialize-param initargs)
   (when (oddp (length initargs))
     (error 'program-error
            :format-control "Odd number of keyword arguments."))
   (unless (getf initargs :allow-other-keys)
-    (let ((slots (%class-slots class)))
+    (let ((methods (compute-applicable-methods #'shared-initialize
+                 (if initargs
+               `(,instance ,shared-initialize-param ,@initargs)
+             (list instance shared-initialize-param))))
+    (slots (%class-slots (class-of instance))))
       (do* ((tail initargs (cddr tail))
             (initarg (car tail) (car tail)))
            ((null tail))
         (unless (or (valid-initarg-p initarg slots)
+        (valid-methodarg-p initarg methods)
                     (eq initarg :allow-other-keys))
           (error 'program-error
@@ -1987 +1992 @@
 
 ;; FIXME
-(defun check-initargs (class initargs)
-  (declare (ignore class initargs)))
+
+;(defun check-initargs (class initargs)
+;  (declare (ignore class initargs)))
+
+(defun valid-methodarg-p (initarg methods)
+  (dolist (method methods nil)
+    (let ((valid-initargs (method-lambda-list method)))
+      (when (find (symbol-value initarg) valid-initargs :test #'string=)
+        (return t)))))
 
 (defun valid-initarg-p (initarg slots)
@@ -2013 +2025 @@
             (setf default-initargs (append default-initargs (list key (funcall fn))))))
         (setf initargs (append initargs default-initargs)))))
-  (check-initargs class initargs)
+
   (let ((instance (std-allocate-instance class)))
+    (check-initargs instance t initargs)
     (apply #'initialize-instance instance initargs)
     instance))
@@ -2099 +2112 @@
                     (mapcar #'%slot-definition-name
                             (%class-slots (class-of new))))))
-    (check-initargs (class-of new) initargs)
+    (check-initargs new added-slots initargs)
     (apply #'shared-initialize new added-slots initargs)))
 
@@ -2128 +2141 @@
             property-list
             &rest initargs)
-  (check-initargs (class-of instance) initargs)
+  (check-initargs instance added-slots initargs)
   (apply #'shared-initialize instance added-slots initargs))