+ ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
+
+(defun gf-requires-emf-keyword-checks (generic-function)
+ (member '&key (gf-lambda-list generic-function)))
+
+(defvar *in-precompute-effective-methods-p* nil)
+
+(defun standard-compute-effective-method
+ (generic-function combin applicable-methods)
+ (collect ((before) (primary) (after) (around))
+ (flet ((invalid (gf combin m)
+ (if *in-precompute-effective-methods-p*
+ (return-from standard-compute-effective-method
+ `(%invalid-qualifiers ',gf ',combin ',m))
+ (invalid-qualifiers gf combin m))))
+ (dolist (m applicable-methods)
+ (let ((qualifiers (if (listp m)
+ (early-method-qualifiers m)
+ (method-qualifiers m))))
+ (cond
+ ((null qualifiers) (primary m))
+ ((cdr qualifiers) (invalid generic-function combin m))
+ ((eq (car qualifiers) :around) (around m))
+ ((eq (car qualifiers) :before) (before m))
+ ((eq (car qualifiers) :after) (after m))
+ (t (invalid generic-function combin m))))))
+ (cond ((null (primary))
+ `(%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; 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))
+ `(multiple-value-prog1
+ (progn
+ ,(make-call-methods (before))
+ (call-method ,(first (primary))
+ ,(rest (primary))))
+ ,(make-call-methods (reverse (after))))
+ `(call-method ,(first (primary)) ,(rest (primary))))))
+ (if (around)
+ `(call-method ,(first (around))
+ (,@(rest (around))
+ (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)))))