[Ecls-list] patch: make initialize-instance allow other keys

[Larry Clapp]

I was fiddling around with some code that works in CMUCL, and it
doesn't work in ECL CVS (and I think it's supposed to work, according
to the HyperSpec), and I narrowed it down to the following test case:

    (defclass class1 () ((slot1 :accessor slot1)))
    (defclass class2 (class1) ())
    (defclass class3 (class2) ())

    (defmethod initialize-instance :after ((obj class1) 
					   &rest args 
					   &key &allow-other-keys)
      (apply #'initialize-slot obj args))

    (defmethod initialize-slot ((obj class2) &key)
      (setf (slot1 obj) 1))

    (defmethod initialize-slot ((obj class3) &key k1 k2 k3)
      (setf (slot1 obj) k2))

    (make-instance 'class3 :k1 1 :k2 2 :k3 3)

The make-instance fails:

    Unknown initialization option K3 for class 
    #<The STANDARD-CLASS CLASS3>

Disclaimer: The following patch might not completely fix the problem,
and might introduce other bugs, and may show a marked misunderstanding
of what's going on either in ECL or in Common Lisp in general ... but
it fixes the test case.  Use at your own risk.

--- 8< cut here ---
--- src/clos/standard.lsp.orig  Sat Mar  6 13:56:02 2004
+++ src/clos/standard.lsp       Sat Mar  6 17:45:48 2004
@@ -462,30 +462,34 @@
 (defun check-initargs (class initargs)
   ;; scan initarg list 
   (do* ((name-loc initargs (cddr name-loc))
-       (allow-other-keys nil)
-       (allow-other-keys-found nil)
-       (unknown-key nil))
+;      (allow-other-keys nil)
+;      (allow-other-keys-found nil)
+;      (unknown-key nil)
+       )
        ((null name-loc)
-       (when (and (not allow-other-keys) unknown-key)
-         (error "Unknown initialization option ~A for class ~A"
-                unknown-key class))
+;      (when (and (not allow-other-keys) unknown-key)
+;        (error "Unknown initialization option ~A for class ~A"
+;               unknown-key class))
        initargs)
     (let ((name (first name-loc)))
       (cond ((null (cdr name-loc))
             (error "No value supplied for the init-name ~S." name))
-           ;; This check must be here, because :ALLOW-OTHER-KEYS is a valid
-           ;; slot-initarg.
-           ((and (eql name :ALLOW-OTHER-KEYS)
-                 (not allow-other-keys-found))
-            (setf allow-other-keys (second name-loc)
-                  allow-other-keys-found t))
-           (;; check if the arguments is associated with a slot
-            (do ((scan-slot (class-slots class) (cdr scan-slot)))
-                ((null scan-slot) ())
-              (when (member name (slotd-initargs (first scan-slot)))
-                (return t))))
-           (t
-            (setf unknown-key name))))))
+; These are all irrelevant, since initialize-instance specifies
+; &allow-other-keys.
+;          ;; This check must be here, because :ALLOW-OTHER-KEYS is a valid
+;          ;; slot-initarg.
+;          ((and (eql name :ALLOW-OTHER-KEYS)
+;                (not allow-other-keys-found))
+;           (setf allow-other-keys (second name-loc)
+;                 allow-other-keys-found t))
+;          (;; check if the arguments is associated with a slot
+;           (do ((scan-slot (class-slots class) (cdr scan-slot)))
+;               ((null scan-slot) ())
+;             (when (member name (slotd-initargs (first scan-slot)))
+;               (return t))))
+;          (t
+;           (setf unknown-key name))
+           ))))
 
 ;;; ----------------------------------------------------------------------
 ;;; Basic access to instances
--- >8 cut here ---