Changeset 13787


Ignore:
Timestamp:
01/17/12 19:39:54 (10 years ago)
Author:
ehuelsmann
Message:

Implement keyword argument verification in the method invocation protocol.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13786 r13787  
    20282028      (return (values nil t)))))))
    20292029
     2030(defun check-applicable-method-keyword-args (gf args
     2031                                             keyword-args
     2032                                             applicable-keywords)
     2033  (when (oddp (length keyword-args))
     2034    (error 'program-error
     2035           :format-control "Odd number of keyword arguments in call to ~S ~
     2036with arguments list ~S"
     2037           :format-arguments (list gf args)))
     2038  (unless (getf keyword-args :allow-other-keys)
     2039    (loop for key in keyword-args by #'cddr
     2040       unless (or (member key applicable-keywords)
     2041                  (eq key :allow-other-keys))
     2042       do (error 'program-error
     2043                 :format-control "Invalid keyword argument ~S in call ~
     2044to ~S with argument list ~S."
     2045                 :format-arguments (list key gf args)))))
     2046
     2047(defun compute-applicable-keywords (gf applicable-methods)
     2048  (let ((applicable-keywords
     2049         (getf (analyze-lambda-list (generic-function-lambda-list gf))
     2050               :keywords)))
     2051    (loop for method in applicable-methods
     2052       do (multiple-value-bind
     2053                (keywords allow-other-keys)
     2054              (function-keywords method)
     2055            (when allow-other-keys
     2056              (setf applicable-keywords :any)
     2057              (return))
     2058            (setf applicable-keywords
     2059                  (union applicable-keywords keywords))))
     2060    applicable-keywords))
     2061
     2062(defun wrap-emfun-for-keyword-args-check (gf emfun non-keyword-args
     2063                                          applicable-keywords)
     2064  #'(lambda (args)
     2065      (check-applicable-method-keyword-args
     2066         gf args
     2067         (nthcdr non-keyword-args args) applicable-keywords)
     2068      (funcall emfun args)))
     2069
    20302070(defun slow-method-lookup (gf args)
    20312071  (let ((applicable-methods (%compute-applicable-methods gf args)))
    20322072    (if applicable-methods
    2033         (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
    2034                                   #'std-compute-effective-method-function
    2035                                   #'compute-effective-method-function)
    2036                               gf applicable-methods)))
     2073        (let* ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
     2074                                   #'std-compute-effective-method-function
     2075                                   #'compute-effective-method-function)
     2076                               gf applicable-methods))
     2077               (non-keyword-args
     2078                (+ (length (gf-required-args gf))
     2079                   (length (gf-optional-args gf))))
     2080               (gf-lambda-list (generic-function-lambda-list gf))
     2081               (checks-required (and (member '&key gf-lambda-list)
     2082                                     (not (member '&allow-other-keys
     2083                                                  gf-lambda-list)))
     2084                 )
     2085              (applicable-keywords
     2086               (when checks-required
     2087                 ;; Don't do applicable keyword checks when this is
     2088                 ;; one of the 'exceptional four' or when the gf allows
     2089                 ;; other keywords.
     2090                 (compute-applicable-keywords gf applicable-methods))))
     2091          (when (and checks-required
     2092                     (not (eq applicable-keywords :any)))
     2093            (setf emfun
     2094                  (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args
     2095                                                     applicable-keywords)))
    20372096          (cache-emf gf args emfun)
    20382097          (funcall emfun args))
     
    24082467    (%set-method-fast-function method fast-function)
    24092468    (set-reader-method-slot-name method slot-name)
     2469    (%set-function-keywords method nil nil)
    24102470    method))
    24112471
     
    28312891              (unless (memq initarg allowable-initargs)
    28322892                (error 'program-error
    2833                        :format-control "Invalid initarg ~S in call to ~S ~
    2834 with arglist ~S."
     2893                       :format-control "Invalid initarg ~S in call to ~S with arglist ~S."
    28352894                       :format-arguments (list initarg call-site args))))))))
    28362895
     
    29503009                                        &key &allow-other-keys))
    29513010
    2952 (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
     3011(defmethod shared-initialize ((instance standard-object) slot-names
     3012                              &rest initargs)
    29533013  (std-shared-initialize instance slot-names initargs))
    29543014
     
    33733433    (%function-keywords method)))
    33743434
    3375 
    33763435(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
    33773436(setf *gf-allocate-instance* (symbol-function 'allocate-instance))
Note: See TracChangeset for help on using the changeset viewer.