-(defun standard-compute-effective-method (generic-function combin applicable-methods)
- (declare (ignore combin))
- (let ((before ())
- (primary ())
- (after ())
- (around ()))
- (dolist (m applicable-methods)
- (let ((qualifiers (if (listp m)
- (early-method-qualifiers m)
- (method-qualifiers m))))
- (cond ((member ':before qualifiers) (push m before))
- ((member ':after qualifiers) (push m after))
- ((member ':around qualifiers) (push m around))
- (t
- (push m primary)))))
- (setq before (reverse before)
- after (reverse after)
- primary (reverse primary)
- around (reverse around))
- (cond ((null primary)
- `(error "There is no primary method for the generic function ~S."
- ',generic-function))
- ((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)))
- (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))))))
+(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))))))