- ((null qualifiers) (push m primary))
- ((cdr qualifiers)
- (lose m "has more than one qualifier"))
- ((eq (car qualifiers) :around)
- (push m around))
- ((eq (car qualifiers) :before)
- (push m before))
- ((eq (car qualifiers) :after)
- (push m after))
- (t
- (lose m "has an illegal qualifier"))))))
- (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))))))
+ ((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)))))
+
+(defun check-applicable-keywords (start valid-keys more-context more-count)
+ (let ((allow-other-keys-seen nil)
+ (allow-other-keys nil)
+ (i start))
+ (declare (type index i more-count)
+ (optimize speed))
+ (flet ((current-value ()
+ (sb-c::%more-arg more-context i)))
+ (declare (inline current-value))
+ (collect ((invalid))
+ (loop
+ (when (>= i more-count)
+ (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 (current-value)))
+ (incf i)
+ (cond
+ ((not (symbolp key))
+ (error 'simple-program-error
+ :format-control "~@<keyword argument not a symbol: ~S.~@:>"
+ :format-arguments (list key)))
+ ((= i more-count)
+ (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 (current-value))))
+ ((eq t valid-keys))
+ ((not (memq key valid-keys)) (invalid key))))
+ (incf i))))))