diff --git a/collects/racket/private/generic.rkt b/collects/racket/private/generic.rkt index 7d29c5df3a..17fdb361ce 100644 --- a/collects/racket/private/generic.rkt +++ b/collects/racket/private/generic.rkt @@ -200,17 +200,14 @@ (define generic (generic-arity-coerce 'generic + ;; We could put `generic-args` here for the method header, but + ;; since we need to keyword-apply the method in the method table, + ;; it doesn't help. Thus we use `make-keyword-procedure`. + ;; + ;; If keyword-apply ends up being a bottleneck, consider + ;; adding the second argument to `make-keyword-procedure` again. (make-keyword-procedure (lambda (kws kws-args . given-args) - (define this (list-ref given-args generic-this-idx)) - (if (name? this) - (let ([m (vector-ref (get-generics this) generic-idx)]) - (if m - (keyword-apply m kws kws-args given-args) - (error 'generic "not implemented for ~e" this))) - (raise-argument-error 'generic name-str this))) - ; XXX (non-this ... this . rst) - (lambda given-args (define this (list-ref given-args generic-this-idx)) (cond [#,(if prop-defined-already? @@ -218,10 +215,10 @@ #'(-name? this)) (let ([m (vector-ref (get-generics this) generic-idx)]) (if m - (apply m given-args) + (keyword-apply m kws kws-args given-args) (error 'generic "not implemented for ~e" this)))] ;; default cases - [(pred? this) (apply cond-impl given-args)] + [(pred? this) (keyword-apply cond-impl kws kws-args given-args)] ... [else (raise-argument-error 'generic name-str this)]))))) ...)))])) diff --git a/collects/tests/generic/pr13737.rkt b/collects/tests/generic/pr13737.rkt new file mode 100644 index 0000000000..be300ab13a --- /dev/null +++ b/collects/tests/generic/pr13737.rkt @@ -0,0 +1,36 @@ +#lang racket + +(require racket/generic + rackunit) + +;; This tests PR 13737 (keyword arguments and #:defaults did +;; not work together) + +(define-generics thing + (foo thing #:stuff other) + #:defaults + {[number? + (define (foo thing #:stuff other) (+ thing other))]}) + +(check-equal? (foo 1 #:stuff 2) 3) + +;; This tests that the keyword & defaults issue doesn't occur for +;; forged generics either + +(let () + (local-require racket/private/generic) + + (define-values (prop:foo foo? foo-accessor) + (make-struct-type-property + 'foo + #f)) + + (define-generics (foo gen:foo prop:foo foo? + #:defined-table dummy + #:defaults ([number? (define (meth foo #:kw kw) kw)]) + #:prop-defined-already? foo-accessor + #:define-contract #f) + (meth foo #:kw kw)) + + (check-equal? (meth 3 #:kw 5) 5)) + diff --git a/collects/tests/generic/tests.rkt b/collects/tests/generic/tests.rkt index fdfb04cc14..6615421c76 100644 --- a/collects/tests/generic/tests.rkt +++ b/collects/tests/generic/tests.rkt @@ -16,4 +16,6 @@ "from-unstable.rkt" "poly-contracts.rkt" "empty-interface.rkt" - "top-level.rkt") + "top-level.rkt" + "pr13737.rkt") +