Re: check-keyword-arguments

[Patrick H Dussud <DUSSUD@Jenner.csc.ti.com>]

     Date: 20 May 88  2206 PDT
     From: Dick Gabriel <RPG@SAIL.STANFORD.EDU>
     Subject: check-keyword-arguments   
     
     
     (defmethod make-instance ((class standard-class) &rest initargs)
       (setq initargs (default-initargs class initargs))
       (let* ((proto (class-prototype class))
              (methods 
                (append
     	     (compute-applicable-methods #'allocate-instance `(,class))
     	     (compute-applicable-methods #'initialize-instance `(,proto))
     	     (compute-applicable-methods #'shared-initialize `(,proto nil)))))
     	(unless
     	  (subsetp
     	    (let ((keys '()))
     	      (do ((plist initargs (cddr plist)))
     		  ((null plist) keys)
     		(push (car plist) keys)))
     	    (union 
     	      (class-slot-initargs class)
     	      (reduce #'union (mapcar #'function-keywords methods))))
     	  (error ...)))
       (let ((instance (apply #'allocate-instance class initargs)))
         (apply #'initialize-instance instance initargs)
         instance))

I agree, expect that the second value returned by function-keywords needs
to be looked at. Something like this would work (I think):

(defmethod make-instance ((class standard-class) &rest initargs)
  (setq initargs (default-initargs class initargs))
  (let* ((proto (class-prototype class))
	 (methods 
	   (append
     	     (compute-applicable-methods #'allocate-instance `(,class))
     	     (compute-applicable-methods #'initialize-instance `(,proto))
     	     (compute-applicable-methods #'shared-initialize `(,proto nil)))))
    (unless
      (block check-keys
	(let ((valid-keys (class-slot-initargs class)))
	  (dolist (method methods)
	    (multiple-value-bind (keys allow-other-keys-p)
		(function-keywords method)
	      (if  allow-other-keys-p
		   (return-from check-keys t)
		   (setf valid-keys (union keys valid-keys)))))
	  (subsetp
	    (let ((keys '()))
	      (do ((plist initargs (cddr plist)))
		  ((null plist) keys)
		(push (car plist) keys)))
	    valid-keys)))
     	  (error ...)))
      (let ((instance (apply #'allocate-instance class initargs)))
	(apply #'initialize-instance instance initargs)
	instance))

Patrick.