diff --git a/src/clos/change.lsp b/src/clos/change.lsp index 30577ef96..67eb33a3c 100644 --- a/src/clos/change.lsp +++ b/src/clos/change.lsp @@ -43,11 +43,12 @@ (setf added-slots (set-difference (mapcar #'slot-definition-name new-local-slotds) (mapcar #'slot-definition-name old-local-slotds))) (check-initargs (class-of new-data) initargs - (append (compute-applicable-methods - #'update-instance-for-different-class - (list old-data new-data)) - (compute-applicable-methods - #'shared-initialize (list new-data added-slots)))) + (valid-keywords-from-methods + (compute-applicable-methods + #'update-instance-for-different-class + (list old-data new-data)) + (compute-applicable-methods + #'shared-initialize (list new-data added-slots)))) (apply #'shared-initialize new-data added-slots initargs))) (defmethod change-class ((instance standard-object) (new-class std-class) @@ -115,12 +116,13 @@ &rest initargs) (declare (ignore discarded-slots property-list)) (check-initargs (class-of instance) initargs - (append (compute-applicable-methods - #'update-instance-for-redefined-class - (list instance added-slots discarded-slots property-list)) - (compute-applicable-methods - #'shared-initialize - (list instance added-slots)))) + (valid-keywords-from-methods + (compute-applicable-methods + #'update-instance-for-redefined-class + (list instance added-slots discarded-slots property-list)) + (compute-applicable-methods + #'shared-initialize + (list instance added-slots)))) (apply #'shared-initialize instance added-slots initargs)) (defun update-instance (instance) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 32c2e2f70..b46f10df3 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -140,7 +140,8 @@ (qualifiers :initform nil :initarg :qualifiers :accessor method-qualifiers) (function :initarg :function :accessor method-function) (documentation :initform nil :initarg documentation) - (plist :initform nil :initarg :plist :accessor method-plist)))) + (plist :initform nil :initarg :plist :accessor method-plist) + (keywords :initform nil :accessor method-keywords)))) #.(create-accessors +standard-method-slots+ 'standard-method) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index a565366b7..223073f4e 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -263,6 +263,16 @@ have disappeared." ;;; ---------------------------------------------------------------------- ;;; operations +(defun add-method-keywords (method) + (multiple-value-bind (reqs opts rest key-flag keywords allow-other-keys) + (si::process-lambda-list (method-lambda-list method) t) + (setf (method-keywords method) + (if allow-other-keys + 't + (loop for k in (rest keywords) by #'cddddr + collect k))) + method)) + (defun make-method (method-class qualifiers specializers lambda-list fun plist options) (declare (ignore options)) @@ -276,7 +286,7 @@ have disappeared." (method-specializers method) specializers (method-qualifiers method) qualifiers (method-plist method) plist) - method)) + (add-method-keywords method))) ;;; early version used during bootstrap (defun method-p (x) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index adf12b9a1..4b56f0866 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -20,10 +20,11 @@ (defmethod reinitialize-instance ((instance T) &rest initargs) (check-initargs (class-of instance) initargs - (append (compute-applicable-methods - #'reinitialize-instance (list instance)) - (compute-applicable-methods - #'shared-initialize (list instance t)))) + (valid-keywords-from-methods + (compute-applicable-methods + #'reinitialize-instance (list instance)) + (compute-applicable-methods + #'shared-initialize (list instance t)))) (apply #'shared-initialize instance '() initargs)) (defmethod shared-initialize ((instance T) slot-names &rest initargs) @@ -110,12 +111,13 @@ ;; (Paul Dietz's ANSI test suite, test CLASS-24.4) (setf initargs (add-default-initargs class initargs)) (check-initargs class initargs - (append (compute-applicable-methods - #'allocate-instance (list class)) - (compute-applicable-methods - #'initialize-instance (list (class-prototype class))) - (compute-applicable-methods - #'shared-initialize (list (class-prototype class) t)))) + (valid-keywords-from-methods + (compute-applicable-methods + #'allocate-instance (list class)) + (compute-applicable-methods + #'initialize-instance (list (class-prototype class))) + (compute-applicable-methods + #'shared-initialize (list (class-prototype class) t)))) (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) instance)) @@ -695,30 +697,22 @@ because it contains a reference to the undefined class~% ~A" ;;; on SHARED-INITIALIZE, REINITIALIZE-INSTANCE, etc. (See ANSI 7.1.2) ;;; -(defun valid-keywords-from-methods (methods) - (declare (si::c-local)) - ;; Given a list of methods, build up the list of valid keyword arguments - (do ((m methods (rest m)) - (keys '())) - ((null m) - (values keys nil)) - (multiple-value-bind (reqs opts rest key-flag keywords allow-other-keys) - (si::process-lambda-list (method-lambda-list (first m)) t) - (when allow-other-keys - (return (values nil t))) - (do ((k (rest keywords) (cddddr k))) - ((null k)) - (push (first k) keys))))) +(defun valid-keywords-from-methods (&rest method-lists) + (let ((keys '())) + (dolist (methods method-lists keys) + ;; Given a list of methods, build up the list of valid keyword arguments + (dolist (m methods) + (let ((keywords (method-keywords m))) + (if (eq keywords t) + (return-from valid-keywords-from-methods t) + (setf keys (append keywords keys)))))))) -(defun check-initargs (class initargs &optional methods +(defun check-initargs (class initargs &optional method-initargs (slots (class-slots class))) ;; First get all initargs which have been declared in the given ;; methods, then check the list of initargs declared in the slots ;; of the class. - (multiple-value-bind (method-initargs allow-other-keys) - (valid-keywords-from-methods methods) - (when allow-other-keys - (return-from check-initargs)) + (unless (eq method-initargs t) (do* ((name-loc initargs (cddr name-loc)) (allow-other-keys nil) (allow-other-keys-found nil) diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index 1ee565648..f2fbe399f 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -56,3 +56,6 @@ (defclass standard-reader-method (standard-accessor-method) ()) (defclass standard-writer-method (standard-accessor-method) ()) + +(defmethod shared-initialized ((method standard-method) &rest initargs) + (add-method-keywords (call-next-method)))