The commit below reduces the number of ANSI failures on my system from 18 to 14!

Bye,

Erik.

---------- Forwarded message ---------- From: ehuelsmann@common-lisp.net Date: Tue, Jan 17, 2012 at 8:39 PM Subject: [armedbear-cvs] r13787 - trunk/abcl/src/org/armedbear/lisp To: armedbear-cvs@common-lisp.net

Author: ehuelsmann Date: Tue Jan 17 11:39:54 2012 New Revision: 13787

Log: Implement keyword argument verification in the method invocation protocol.

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

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 11:38:01 2012        (r13786) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 11:39:54 2012        (r13787) @@ -2027,13 +2027,72 @@          (unless (subclassp (car classes) specializer)            (return (values nil t)))))))

+(defun check-applicable-method-keyword-args (gf args +                                             keyword-args +                                             applicable-keywords) +  (when (oddp (length keyword-args)) +    (error 'program-error +           :format-control "Odd number of keyword arguments in call to ~S ~ +with arguments list ~S" +           :format-arguments (list gf args))) +  (unless (getf keyword-args :allow-other-keys) +    (loop for key in keyword-args by #'cddr +       unless (or (member key applicable-keywords) +                  (eq key :allow-other-keys)) +       do (error 'program-error +                 :format-control "Invalid keyword argument ~S in call ~ +to ~S with argument list ~S." +                 :format-arguments (list key gf args))))) + +(defun compute-applicable-keywords (gf applicable-methods) +  (let ((applicable-keywords +         (getf (analyze-lambda-list (generic-function-lambda-list gf)) +               :keywords))) +    (loop for method in applicable-methods +       do (multiple-value-bind +                (keywords allow-other-keys) +              (function-keywords method) +            (when allow-other-keys +              (setf applicable-keywords :any) +              (return)) +            (setf applicable-keywords +                  (union applicable-keywords keywords)))) +    applicable-keywords)) + +(defun wrap-emfun-for-keyword-args-check (gf emfun non-keyword-args +                                          applicable-keywords) +  #'(lambda (args) +      (check-applicable-method-keyword-args +         gf args +         (nthcdr non-keyword-args args) applicable-keywords) +      (funcall emfun args))) +  (defun slow-method-lookup (gf args)   (let ((applicable-methods (%compute-applicable-methods gf args)))     (if applicable-methods -        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) -                                  #'std-compute-effective-method-function -                                  #'compute-effective-method-function) -                              gf applicable-methods))) +        (let* ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) +                                   #'std-compute-effective-method-function +                                   #'compute-effective-method-function) +                               gf applicable-methods)) +               (non-keyword-args +                (+ (length (gf-required-args gf)) +                   (length (gf-optional-args gf)))) +               (gf-lambda-list (generic-function-lambda-list gf)) +               (checks-required (and (member '&key gf-lambda-list) +                                     (not (member '&allow-other-keys +                                                  gf-lambda-list))) +                 ) +              (applicable-keywords +               (when checks-required +                 ;; Don't do applicable keyword checks when this is +                 ;; one of the 'exceptional four' or when the gf allows +                 ;; other keywords. +                 (compute-applicable-keywords gf applicable-methods)))) +          (when (and checks-required +                     (not (eq applicable-keywords :any))) +            (setf emfun +                  (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args +                                                     applicable-keywords)))           (cache-emf gf args emfun)           (funcall emfun args))         (apply #'no-applicable-method gf args)))) @@ -2407,6 +2466,7 @@     (%set-method-function method function)     (%set-method-fast-function method fast-function)     (set-reader-method-slot-name method slot-name) +    (%set-function-keywords method nil nil)     method))

(defun add-reader-method (class function-name slot-name) @@ -2830,8 +2890,7 @@               ((null tail))               (unless (memq initarg allowable-initargs)                 (error 'program-error -                       :format-control "Invalid initarg ~S in call to ~S ~ -with arglist ~S." +                       :format-control "Invalid initarg ~S in call to ~S with arglist ~S."                        :format-arguments (list initarg call-site args))))))))

(defun merge-initargs-sets (list1 list2) @@ -2949,7 +3008,8 @@                                         &rest initargs                                         &key &allow-other-keys))

-(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) +(defmethod shared-initialize ((instance standard-object) slot-names +                              &rest initargs)   (std-shared-initialize instance slot-names initargs))

(defmethod shared-initialize ((slot slot-definition) slot-names @@ -3372,7 +3432,6 @@   (:method ((method standard-method))     (%function-keywords method)))

-  (setf *gf-initialize-instance* (symbol-function 'initialize-instance))  (setf *gf-allocate-instance* (symbol-function 'allocate-instance))  (setf *gf-shared-initialize* (symbol-function 'shared-initialize))

_______________________________________________ armedbear-cvs mailing list armedbear-cvs@common-lisp.net http://lists.common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs