(get-generic-fun-info gf)
(declare (ignore nreq nkeys arg-info))
(let ((ll (make-fast-method-call-lambda-list metatypes applyp))
+ (check-applicable-keywords
+ (when (and applyp (gf-requires-emf-keyword-checks gf))
+ '((check-applicable-keywords))))
(error-p (or (eq (first effective-method) '%no-primary-method)
(eq (first effective-method) '%invalid-qualifiers)))
(mc-args-p
(declare (ignore .pv-cell. .next-method-call.))
(let ((.gf-args. ,gf-args))
(declare (ignorable .gf-args.))
+ ,@check-applicable-keywords
,effective-method))))
(t
`(lambda ,ll
(declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
+ ,@check-applicable-keywords
,effective-method))))))
(defun expand-emf-call-method (gf form metatypes applyp env)
(declare (ignore args))
`(error "~S outside of a effective method form" 'call-method))
+(defun make-effective-method-list-fun-type
+ (generic-function form method-alist-p wrappers-p)
+ (if (every (lambda (form)
+ (eq 'fast-method-call
+ (make-effective-method-fun-type
+ generic-function form method-alist-p wrappers-p)))
+ (cdr form))
+ 'fast-method-call
+ t))
+
(defun memf-test-converter (form generic-function method-alist-p wrappers-p)
- (cond ((and (consp form) (eq (car form) 'call-method))
- (case (make-effective-method-fun-type
- generic-function form method-alist-p wrappers-p)
- (fast-method-call
- '.fast-call-method.)
- (t
- '.call-method.)))
- ((and (consp form) (eq (car form) 'call-method-list))
- (case (if (every (lambda (form)
- (eq 'fast-method-call
- (make-effective-method-fun-type
- generic-function form
- method-alist-p wrappers-p)))
- (cdr form))
- 'fast-method-call
- t)
- (fast-method-call
- '.fast-call-method-list.)
- (t
- '.call-method-list.)))
- (t
- (default-test-converter form))))
+ (case (and (consp form) (car form))
+ (call-method
+ (case (make-effective-method-fun-type
+ generic-function form method-alist-p wrappers-p)
+ (fast-method-call '.fast-call-method.)
+ (t '.call-method.)))
+ (call-method-list
+ (case (make-effective-method-list-fun-type
+ generic-function form method-alist-p wrappers-p)
+ (fast-method-call '.fast-call-method-list.)
+ (t '.call-method-list.)))
+ (check-applicable-keywords 'check-applicable-keywords)
+ (t (default-test-converter form))))
+;;; CMUCL comment (2003-10-15):
+;;;
+;;; This function is called via the GET-FUNCTION mechanism on forms
+;;; of an emf lambda. First value returned replaces FORM in the emf
+;;; lambda. Second value is a list of variable names that become
+;;; closure variables.
(defun memf-code-converter
(form generic-function metatypes applyp method-alist-p wrappers-p)
- (cond ((and (consp form) (eq (car form) 'call-method))
- (let ((gensym (get-effective-method-gensym)))
- (values (make-emf-call metatypes applyp gensym
- (make-effective-method-fun-type
- generic-function form method-alist-p wrappers-p))
- (list gensym))))
- ((and (consp form) (eq (car form) 'call-method-list))
- (let ((gensym (get-effective-method-gensym))
- (type (if (every (lambda (form)
- (eq 'fast-method-call
- (make-effective-method-fun-type
- generic-function form
- method-alist-p wrappers-p)))
- (cdr form))
- 'fast-method-call
- t)))
- (values `(dolist (emf ,gensym nil)
- ,(make-emf-call metatypes applyp 'emf type))
- (list gensym))))
- (t
- (default-code-converter form))))
+ (case (and (consp form) (car form))
+ (call-method
+ (let ((gensym (get-effective-method-gensym)))
+ (values (make-emf-call
+ metatypes applyp gensym
+ (make-effective-method-fun-type
+ generic-function form method-alist-p wrappers-p))
+ (list gensym))))
+ (call-method-list
+ (let ((gensym (get-effective-method-gensym))
+ (type (make-effective-method-list-fun-type
+ generic-function form method-alist-p wrappers-p)))
+ (values `(dolist (emf ,gensym nil)
+ ,(make-emf-call metatypes applyp 'emf type))
+ (list gensym))))
+ (check-applicable-keywords
+ (values `(check-applicable-keywords
+ .dfun-rest-arg. .keyargs-start. .valid-keys.)
+ '(.keyargs-start. .valid-keys.)))
+
+ (t
+ (default-code-converter form))))
(defun memf-constant-converter (form generic-function)
- (cond ((and (consp form) (eq (car form) 'call-method))
- (list (cons '.meth.
- (make-effective-method-function-simple
- generic-function form))))
- ((and (consp form) (eq (car form) 'call-method-list))
- (list (cons '.meth-list.
- (mapcar (lambda (form)
- (make-effective-method-function-simple
- generic-function form))
- (cdr form)))))
- (t
- (default-constant-converter form))))
+ (case (and (consp form) (car form))
+ (call-method
+ (list (cons '.meth.
+ (make-effective-method-function-simple
+ generic-function form))))
+ (call-method-list
+ (list (cons '.meth-list.
+ (mapcar (lambda (form)
+ (make-effective-method-function-simple
+ generic-function form))
+ (cdr form)))))
+ (check-applicable-keywords
+ '(.keyargs-start. .valid-keys.))
+ (t
+ (default-constant-converter form))))
+(defvar *applicable-methods*)
(defun make-effective-method-function-internal
(generic-function effective-method method-alist-p wrappers-p)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
(lambda (form)
(memf-constant-converter form generic-function)))
(lambda (method-alist wrappers)
- (let* ((constants
- (mapcar (lambda (constant)
- (if (consp constant)
- (case (car constant)
- (.meth.
- (funcall (cdr constant)
- method-alist wrappers))
- (.meth-list.
- (mapcar (lambda (fn)
- (funcall fn
- method-alist
- wrappers))
- (cdr constant)))
- (t constant))
- constant))
- constants))
- (function (set-fun-name
- (apply cfunction constants)
- `(combined-method ,name))))
- (make-fast-method-call :function function
- :arg-info arg-info)))))))
+ (multiple-value-bind (valid-keys keyargs-start)
+ (when (memq '.valid-keys. constants)
+ (compute-applicable-keywords
+ generic-function *applicable-methods*))
+ (flet ((compute-constant (constant)
+ (if (consp constant)
+ (case (car constant)
+ (.meth.
+ (funcall (cdr constant) method-alist wrappers))
+ (.meth-list.
+ (mapcar (lambda (fn)
+ (funcall fn method-alist wrappers))
+ (cdr constant)))
+ (t constant))
+ (case constant
+ (.keyargs-start. keyargs-start)
+ (.valid-keys. valid-keys)
+ (t constant)))))
+ (let ((fun (apply cfunction
+ (mapcar #'compute-constant constants))))
+ (set-fun-name fun `(combined-method ,name))
+ (make-fast-method-call :function fun
+ :arg-info arg-info)))))))))
(defmacro call-method-list (&rest calls)
`(progn ,@calls))
`(call-method-list
,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
+(defun gf-requires-emf-keyword-checks (generic-function)
+ (member '&key (gf-lambda-list generic-function)))
+
(defun standard-compute-effective-method
(generic-function combin applicable-methods)
(collect ((before) (primary) (after) (around))
`(%no-primary-method ',generic-function .args.))
((and (null (before)) (null (after)) (null (around)))
;; By returning a single call-method `form' here we enable
- ;; an important implementation-specific optimization.
- `(call-method ,(first (primary)) ,(rest (primary))))
+ ;; an important implementation-specific optimization; that
+ ;; is, we can use the fast method function directly as the
+ ;; effective method function.
+ ;;
+ ;; However, the requirement by ANSI (CLHS 7.6.5) on generic
+ ;; function argument checking inhibits this, as we don't
+ ;; perform this checking in fast-method-functions given
+ ;; that they are not solely used for effective method
+ ;; functions, but also in combination, when they should not
+ ;; perform argument checks.
+ (let ((call-method
+ `(call-method ,(first (primary)) ,(rest (primary)))))
+ (if (gf-requires-emf-keyword-checks generic-function)
+ ;; the PROGN inhibits the above optimization
+ `(progn ,call-method)
+ call-method)))
(t
(let ((main-effective-method
(if (or (before) (after))
(make-method ,main-effective-method)))
main-effective-method))))))
\f
+;;; helper code for checking keywords in generic function calls.
+(defun compute-applicable-keywords (gf methods)
+ (let ((any-keyp nil))
+ (flet ((analyze (lambda-list)
+ (multiple-value-bind (nreq nopt keyp restp allowp keys)
+ (analyze-lambda-list lambda-list)
+ (declare (ignore nreq restp))
+ (when keyp
+ (setq any-keyp t))
+ (values nopt allowp keys))))
+ (multiple-value-bind (nopt allowp keys)
+ (analyze (generic-function-lambda-list gf))
+ (dolist (method methods)
+ (let ((ll (if (consp method)
+ (early-method-lambda-list method)
+ (method-lambda-list method))))
+ (multiple-value-bind (n allowp method-keys)
+ (analyze ll)
+ (declare (ignore n))
+ (when allowp
+ (return-from compute-applicable-keywords (values t nopt)))
+ (setq keys (union method-keys keys)))))
+ (aver any-keyp)
+ (values (if allowp t keys) nopt)))))
+
+(defun check-applicable-keywords (args start valid-keys)
+ (let ((allow-other-keys-seen nil)
+ (allow-other-keys nil)
+ (args (nthcdr start args)))
+ (collect ((invalid))
+ (loop
+ (when (null args)
+ (when (and (invalid) (not allow-other-keys))
+ (error 'simple-program-error
+ :format-control "~@<invalid keyword argument~P: ~
+ ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
+ :format-arguments (list (length (invalid)) (invalid) valid-keys)))
+ (return))
+ (let ((key (pop args)))
+ (cond
+ ((not (symbolp key))
+ (error 'simple-program-error
+ :format-control "~@<keyword argument not a symbol: ~S.~@:>"
+ :format-arguments (list key)))
+ ((null args) (sb-c::%odd-key-args-error))
+ ((eq key :allow-other-keys)
+ ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
+ (unless allow-other-keys-seen
+ (setq allow-other-keys-seen t
+ allow-other-keys (car args))))
+ ((eq t valid-keys))
+ ((not (memq key valid-keys)) (invalid key))))
+ (pop args)))))
+\f
;;;; the STANDARD method combination type. This is coded by hand
;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
;;;; and efficiency reasons. Note that the definition of the
(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
(when (eq *boot-state* 'complete)
- (unless caching-p
+ (unless (or caching-p (gf-requires-emf-keyword-checks gf))
;; This should return T when almost all dispatching is by
;; eql specializers or built-in classes. In other words,
;; return NIL if we might ever need to do more than
(setq *wrapper-of-cost* 15)
(setq *secondary-dfun-call-cost* 30)
+(declaim (inline make-callable))
+(defun make-callable (gf methods generator method-alist wrappers)
+ (let* ((*applicable-methods* methods)
+ (callable (function-funcall generator method-alist wrappers)))
+ callable))
+
(defun make-dispatch-dfun (gf)
(values (get-dispatch-function gf) nil (dispatch-dfun-info)))
(defun get-dispatch-function (gf)
- (let ((methods (generic-function-methods gf)))
- (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil
- nil nil t)
- nil nil)))
+ (let* ((methods (generic-function-methods gf))
+ (generator (get-secondary-dispatch-function1
+ gf methods nil nil nil nil nil t)))
+ (make-callable gf methods generator nil nil)))
(defun make-final-dispatch-dfun (gf)
(make-dispatch-dfun gf))
(let* ((for-accessor-p (eq state 'accessor))
(for-cache-p (or (eq state 'caching) (eq state 'accessor)))
(emf (if (or cam-std-p all-applicable-and-sorted-p)
- (function-funcall (get-secondary-dispatch-function1
- gf methods types nil (and for-cache-p
- wrappers)
- all-applicable-and-sorted-p)
- nil (and for-cache-p wrappers))
+ (let ((generator
+ (get-secondary-dispatch-function1
+ gf methods types nil (and for-cache-p wrappers)
+ all-applicable-and-sorted-p)))
+ (make-callable gf methods generator
+ nil (and for-cache-p wrappers)))
(default-secondary-dispatch-function gf))))
(multiple-value-bind (index accessor-type)
(and for-accessor-p all-applicable-and-sorted-p methods
(dolist (method (generic-function-methods generic-function))
(remhash method *effective-method-cache*)))
-(defun get-secondary-dispatch-function (gf methods types &optional
- method-alist wrappers)
- (function-funcall (get-secondary-dispatch-function1
- gf methods types
- (not (null method-alist))
- (not (null wrappers))
- (not (methods-contain-eql-specializer-p methods)))
- method-alist wrappers))
+(defun get-secondary-dispatch-function (gf methods types
+ &optional method-alist wrappers)
+ (let ((generator
+ (get-secondary-dispatch-function1
+ gf methods types (not (null method-alist)) (not (null wrappers))
+ (not (methods-contain-eql-specializer-p methods)))))
+ (make-callable gf methods generator method-alist wrappers)))
(defun get-secondary-dispatch-function1 (gf methods types method-alist-p
wrappers-p
(defun get-effective-method-function (gf methods
&optional method-alist wrappers)
- (function-funcall (get-secondary-dispatch-function1 gf methods nil
- (not (null method-alist))
- (not (null wrappers))
- t)
- method-alist wrappers))
+ (let ((generator
+ (get-secondary-dispatch-function1
+ gf methods nil (not (null method-alist)) (not (null wrappers)) t)))
+ (make-callable gf methods generator method-alist wrappers)))
(defun get-effective-method-function1 (gf methods &optional (sorted-p t))
(get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
projects / sbcl.git / commitdiff