[armedbear-devel] Fwd: [armedbear-cvs] r13787 - trunk/abcl/src/org/armedbear/lisp

[Blake McBride]

Great work!  Thanks!!

On Tue, Jan 17, 2012 at 1:48 PM, Erik Huelsmann
<ehuelsmann at common-lisp.net> wrote:
> The commit below reduces the number of ANSI failures on my system from 18 to 14!
>
> Bye,
>
> Erik.
>
>
> ---------- Forwarded message ----------
> From:  <ehuelsmann at 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 at 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 at common-lisp.net
> http://lists.common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs
> _______________________________________________
> armedbear-devel mailing list
> armedbear-devel at common-lisp.net
> http://lists.common-lisp.net/cgi-bin/mailman/listinfo/armedbear-devel