Adapted define-generics so that "defaults" work like #:methods implementations.

Specifically, implementations for the #:defaults keyword in define-generics can
now use define/generic to get at the generic implementation of a method for
which a specific implementation is defined locally.  Also, unimplemented methods
are handled properly now in #:defaults.  Previously, an unimplemented method in
a #:defaults specification would go into an infinite loop if applied, because
the implementation for the specific type wound up referring to the generic
implementation of the method.

A lot of the back-end implementation of generics changes in this commit:

- The new module racket/private/generic-methods provides a uniform mechanism for
  defining method tables and recording static information about generics
  groups.  Both #:methods in [define-]struct and #:defaults in define-generics
  use this framework now.  In addition, generics based on existing properties
  such as gen:stream, gen:equal+hash, and gen:custom-write now use the struct
  from this module to store the names associated with the generics groups.

- Generic methods now expand directly into functions with the appropriate arity,
  and refer directly to the appropriate argument to perform generic method
  dispatch.  The previous implementation used procedure-reduce-keyword-arity to
  restrict the arity dynamically, and used list-ref to find the generic
  argument.

- Some error messages have changed slightly; hopefully for the better, but this
  change did require some changes to tests for specific error messages.

pkgs/racket-pkgs/racket-test/tests/generic/errors.rkt

@@ -5,12 +5,15 @@
 (module+ test
   (require rackunit)
 
-  (check-exn #rx"not a name for a generics group"
+  (check-exn #rx"expected 2 arguments after keyword"
              (lambda () (convert-compile-time-error
                          (struct foo () #:methods 3))))
   (check-exn #rx"not a name for a generics group"
              (lambda () (convert-compile-time-error
-                         (struct foo () #:methods bad))))
+                         (struct foo () #:methods 3 ()))))
+  (check-exn #rx"not a name for a generics group"
+             (lambda () (convert-compile-time-error
+                         (struct foo () #:methods bad ()))))
   (check-exn #rx"method definition has an incorrect arity"
              (lambda () (convert-compile-time-error
                          (let ()

pkgs/racket-pkgs/racket-test/tests/generic/from-unstable.rkt

@@ -95,12 +95,12 @@
   (define-generics table
     (get idx [default]))
   =error>
-  "No required by-position generic argument"
+  #px"generic(s group)? name.+required,? (by-position|positional) argument"
 
   (define-generics table
     (get idx [table] [default]))
   =error>
-  "No required by-position generic argument")
+  #px"generic(s group)? name.+required,? (by-position|positional) argument")
 
 
  (local [(define-generics printable

pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt

@@ -1,6 +1,8 @@
 #lang racket/base
 
-(require racket/private/generic racket/sequence (for-syntax racket/base))
+(require racket/private/generic-methods
+         racket/sequence
+         (for-syntax racket/base))
 
 ;; This was designed as a higher-level interface on top of sequences,
 ;; but it turns out streams can do all that already (including state),
@@ -50,10 +52,10 @@
   (proc i))
 
 (define-syntax gen:iterator
-  (list (quote-syntax prop:iterator)
+  (make-generic-info (quote-syntax prop:iterator)
-        (quote-syntax iterator-first)
+                     (list (quote-syntax iterator-first)
                            (quote-syntax iterator-rest)
-        (quote-syntax iterator-continue?)))
+                           (quote-syntax iterator-continue?))))
 
 (struct list-iterator (l)
         #:methods gen:iterator

racket/lib/collects/racket/generic.rkt

@@ -71,8 +71,10 @@
        (define/with-syntax prop-name (generate-temporary #'name))
        (define/with-syntax get-name (generate-temporary #'name))
        (define/with-syntax table-name table)
+       (define/with-syntax original stx)
        #'(begin
-           (define-primitive-generics
+           (define-primitive-generics/derived
+             original
              (name gen-name prop-name get-name pred-name
                    #:defined-table table-name
                    #:defaults [default ...])

racket/lib/collects/racket/private/define-struct.rkt

@@ -3,6 +3,7 @@
 
 (module define-struct '#%kernel
   (#%require "small-scheme.rkt" "define.rkt" "../stxparam.rkt"
+             "generic-methods.rkt"
              (for-syntax '#%kernel "define.rkt"
                          "procedure-alias.rkt"
                          "member.rkt"
@@ -14,7 +15,6 @@
              define-struct/derived
              struct-field-index
              struct-copy
-             define/generic
              (for-syntax
               (rename checked-struct-info-rec? checked-struct-info?)))
 
@@ -116,10 +116,6 @@
       (raise-argument-error name "symbol?" what))
     what)
 
-  (define-syntax-parameter define/generic
-    (lambda (stx)
-      (raise-syntax-error 'define/generic "only allowed inside methods" stx)))
-
   (define-syntax (define-struct* stx)
     (syntax-case stx ()
       [(_ . rest)
@@ -287,61 +283,23 @@
                 nongen?)]
          [(eq? '#:methods (syntax-e (car p)))
           ;; #:methods gen:foo [(define (meth1 x ...) e ...) ...]
-          ;; `gen:foo' is bound to (prop:foo generic ...)
+          (check-exprs 2 p "argument")
-          (define (build-method-table gen specs mthds) ; mthds is syntax
+          (define gen-id (cadr p))
-            (with-syntax ([(generic ...)
+          (define gen-defs (caddr p))
-                           specs]
+          (define args (cdddr p))
-                          [(mthd-generic ...)
+          (define gen-val
-                           (map (λ (g) (datum->syntax mthds (syntax->datum g)))
+            (and (identifier? gen-id)
-                                specs)])
+                 (syntax-local-value gen-id (lambda () #f))))
-              (quasisyntax/loc gen
+          (unless (generic-info? gen-val)
-                (let ([mthd-generic #f]
+            (bad "the first argument to the "
-                      ...)
+                 (car p)
-                  (syntax-parameterize
+                 " is not a name for a generics group"))
-                   ([define/generic
+          (loop (list* #'#:property
-                      (lambda (stx)
+                       (quasisyntax/loc gen-id
-                        (syntax-case stx (mthd-generic ...)
+                         (generic-property #,gen-id))
-                          [(_ new-name mthd-generic)
+                       (quasisyntax/loc gen-id
-                           (syntax/loc stx
+                         (generic-method-table #,gen-id #,@gen-defs))
-                             (define new-name generic))]
+                       args)
-                          ...
-                          [(_ new-name method-name)
-                           (raise-syntax-error 'define/generic
-                             (format "~.s not a method of ~.s"
-                                     (syntax->datum #'method-name)
-                                     '#,gen)
-                             stx
-                             #'method-name)]))])
-                   (let ()
-                     #,@mthds
-                     (vector mthd-generic ...)))))))
-          (define gen:foo (cadr p))
-          (define (bad-generics)
-            (raise-syntax-error #f
-                                "not a name for a generics group"
-                                gen:foo gen:foo))
-          (unless (and (identifier? gen:foo)
-                       ;; at the top-level, it's not possible to check
-                       ;; if this `gen:foo` is bound, so we give up on the
-                       ;; error message in that case
-                       (or (eq? (syntax-local-context) 'top-level)
-                           (identifier-binding gen:foo)))
-            (bad-generics))
-          (define gen:foo-val (syntax-local-value gen:foo))
-          (unless (and (list? gen:foo-val)
-                       (>= (length gen:foo-val) 1))
-            (bad-generics))
-          (define prop:foo    (car gen:foo-val))
-          (define meth-specs  (cdr gen:foo-val))
-          (unless (and (identifier? prop:foo)
-                       (list? meth-specs)
-                       (andmap identifier? meth-specs))
-            (bad-generics))
-          (define meths       (caddr p))
-          (loop (cons #'#:property
-                      (cons prop:foo
-                            (cons (build-method-table gen:foo meth-specs meths)
-                                  (cdddr p)))) ; post #:generics args
                 config
                 nongen?)]
          [(eq? '#:inspector (syntax-e (car p)))

racket/lib/collects/racket/private/generic-interfaces.rkt

@@ -6,7 +6,7 @@
   ;; `define-generics' to build these generic interfaces. Thus we must
   ;; forge them.
 
-  (#%require (for-syntax '#%kernel))
+  (#%require (for-syntax '#%kernel) "generic-methods.rkt")
 
   (#%provide gen:equal+hash gen:custom-write)
 
@@ -37,10 +37,10 @@
   (define (hash2-proc x h) (equal-secondary-hash-code x))
 
   (define-syntax gen:equal+hash
-    (list (quote-syntax prop:gen:equal+hash)
+    (make-generic-info (quote-syntax prop:gen:equal+hash)
-          (quote-syntax equal-proc)
+                       (list (quote-syntax equal-proc)
                              (quote-syntax hash-proc)
-          (quote-syntax hash2-proc)))
+                             (quote-syntax hash2-proc))))
 
 
   (define-values (prop:gen:custom-write gen:custom-write? gen:custom-write-acc)
@@ -66,7 +66,7 @@
       [else (error 'write-proc "internal error; should not happen")]))
 
   (define-syntax gen:custom-write
-    (list (quote-syntax prop:gen:custom-write)
+    (make-generic-info (quote-syntax prop:gen:custom-write)
-          (quote-syntax write-proc)))
+                       (list (quote-syntax write-proc))))
 
   )

racket/lib/collects/racket/private/generic-methods.rkt

@@ -0,0 +1,131 @@
+(module generic-methods '#%kernel
+
+  (#%require (for-syntax '#%kernel "small-scheme.rkt" "define.rkt"
+                         "stx.rkt" "stxcase-scheme.rkt")
+             "define.rkt" "../stxparam.rkt")
+
+  (#%provide define/generic
+             generic-property
+             generic-method-table
+             (for-syntax generic-info?
+                         make-generic-info
+                         generic-info-property
+                         generic-info-methods))
+
+  (begin-for-syntax
+
+    (define-values (struct:generic-info
+                    make-generic-info
+                    generic-info?
+                    generic-info-get
+                    generic-info-set!)
+      (make-struct-type 'generic-info #f 2 0))
+
+    (define-values (generic-info-property
+                    generic-info-methods)
+      (values (make-struct-field-accessor generic-info-get 0 'property)
+              (make-struct-field-accessor generic-info-get 1 'methods)))
+
+    (define (check-identifier! name ctx stx)
+      (unless (identifier? stx)
+        (raise-syntax-error name "expected an identifier" ctx stx)))
+
+    (define (get-info name ctx stx)
+      (check-identifier! name ctx stx)
+      (define info (syntax-local-value stx (lambda () #f)))
+      (unless (generic-info? info)
+        (raise-syntax-error name "bad generics group name" ctx stx))
+      info)
+
+    (define (unimplemented-transformer un stx)
+      (define name (unimplemented-method un))
+      (raise-syntax-error name "method not implemented" stx))
+
+    (define-values (struct:unimplemented
+                    make-unimplemented
+                    unimplemented?
+                    unimplemented-get
+                    unimplemented-set!)
+      (make-struct-type 'unimplemented
+                        #f
+                        1
+                        0
+                        #f
+                        (list (cons prop:set!-transformer
+                                    unimplemented-transformer))))
+
+    (define unimplemented-method
+      (make-struct-field-accessor unimplemented-get 0 'method)))
+
+  (define-syntax-parameter generic-method-context #f)
+
+  (define-syntax (implementation stx)
+    (syntax-case stx ()
+      [(_ method)
+       (let ([val (syntax-local-value #'method (lambda () #f))])
+         (cond
+           [(unimplemented? val) #'(quote #f)]
+           [else #'method]))]))
+
+  (define-syntax (generic-property stx)
+    (syntax-case stx ()
+      [(_ gen)
+       (generic-info-property (get-info 'generic-property stx #'gen))]))
+
+  (define-syntax (generic-method-table stx)
+    (syntax-case stx ()
+      [(_ gen def ...)
+       (let ()
+         (define info (get-info 'generic-method-table stx #'gen))
+         (define delta (syntax-local-make-delta-introducer #'gen))
+         (define methods (map delta (generic-info-methods info)))
+         (with-syntax ([(method ...) methods])
+           (syntax/loc stx
+             (syntax-parameterize ([generic-method-context #'gen])
+               (letrec-syntaxes+values
+                   ([(method) (make-unimplemented 'method)] ...)
+                   ()
+                 def ...
+                 (vector (implementation method) ...))))))]))
+
+  (define-syntax (define/generic stx)
+    (define gen-id (syntax-parameter-value #'generic-method-context))
+    (define gen-val
+      (and (identifier? gen-id)
+           (syntax-local-value gen-id (lambda () #f))))
+    (unless (generic-info? gen-val)
+      (raise-syntax-error 'define/generic "only allowed inside methods" stx))
+    (syntax-case stx ()
+      [(_ bind ref)
+       (let ()
+         (unless (identifier? #'bind)
+           (raise-syntax-error 'define/generic "expected an identifier" #'bind))
+         (unless (identifier? #'ref)
+           (raise-syntax-error 'define/generic "expected an identifier" #'ref))
+         (define delta (syntax-local-make-delta-introducer gen-id))
+         (define methods (generic-info-methods gen-val))
+         (define matches
+           (let loop ([methods methods])
+             (cond
+               [(null? methods) '()]
+               [(free-identifier=? (syntax-local-get-shadower
+                                    (delta (car methods)))
+                                   #'ref)
+                (cons (car methods) (loop (cdr methods)))]
+               [else (loop (cdr methods))])))
+         (unless (pair? matches)
+           (raise-syntax-error 'define/generic
+                               (format "~.s is not a method of ~.s"
+                                       (syntax-e #'ref)
+                                       (syntax-e gen-id))
+                               stx
+                               #'ref))
+         (when (pair? (cdr matches))
+           (raise-syntax-error 'define/generic
+                               (format "multiple methods match ~.s: ~.s"
+                                       (syntax-e #'ref)
+                                       (map syntax-e matches))
+                               stx
+                               #'ref))
+         (with-syntax ([method (car matches)])
+           #'(define bind method)))])))

racket/lib/collects/racket/private/generic.rkt

@@ -1,197 +1,428 @@
 #lang racket/base
-(require racket/local
+(require (for-syntax racket/base
-         (for-syntax racket/base
                      racket/local
                      racket/syntax
-                     syntax/stx)
+                     syntax/stx
-         (only-in "define-struct.rkt" define/generic)
+                     syntax/boundmap)
+         "generic-methods.rkt"
          (only-in racket/function arity-includes?))
 
-(define-for-syntax (keyword-stx? v)
+(provide define-primitive-generics
+         define-primitive-generics/derived
+         define/generic)
+
+(begin-for-syntax
+
+  (define (keyword-stx? v)
     (keyword? (syntax->datum v)))
 
-(provide define-primitive-generics define/generic)
+  (define (check-identifier! stx)
-(define-syntax (define-primitive-generics stx)
+    (unless (identifier? stx)
-  (syntax-case stx () ; can't use syntax-parse, since it depends on us
+      (wrong-syntax stx "expected an identifier")))
-    ;; keyword arguments must _all_ be provided _in_order_. For the
-    ;; user-facing version of `define-generics', see racket/generic.
-    ;;
-    ;; The `header` is the original name the library writer provides
-    ;; that is used to define the `name`, `prop:name`, and `name?`
-    ;; identifiers. We have it here so that we can use it to match
-    ;; the method header's self argument.
-    [(_ (header name prop:name get-generics name?
-                #:defined-table defined-table
-                #:defaults
-                ([pred? impl ...]
-                 ;; TODO fallthrough?
-                 ...))
-        (generic . generic-args) ...)
-     (and (identifier? #'header)
-          (identifier? #'name)
-          (identifier? #'prop:name)
-          (identifier? #'get-generics)
-          (identifier? #'name?)
-          (identifier? #'defined-table)
-          (let ([generics (syntax->list #'(generic ...))])
-            (and (list? generics)
-                 (andmap identifier? generics))))
-     (let* ([generics (syntax->list #'(generic ...))]
-            [name-str (symbol->string (syntax-e #'name?))]
-            [idxs (for/list ([i (in-naturals 0)]
-                             [_ generics])
-                    i)]
-            ;; syntax introducers for each default implementation set
-            ;; these connect the default method definitions to the
-            ;; appropriate dispatch reference in the generic function body
-            [pred-introducers (map (λ (_) (make-syntax-introducer))
-                                   (syntax->list #'(pred? ...)))]
-            ;; mark each set of default methods for a default set and
-            ;; then flatten all of the default definitions
-            [method-impl-list
-             (apply append
-              (map syntax->list
-                   (for/list ([introducer pred-introducers]
-                              [meths (syntax->list #'((impl ...) ...))])
-                     (introducer meths))))]
-            ;; mark each generic function name for a default set
-            [marked-generics
-             (for/list ([generic generics])
-               (for/list ([introducer pred-introducers])
-                 (introducer generic)))])
-       (with-syntax ([name-str name-str]
-                     [how-many-generics (length idxs)]
-                     [(generic-arity-coerce ...) (generate-temporaries #'(generic ...))]
-                     [(generic-idx ...) idxs]
-                     [(generic-this-idx ...)
-                      (for/list ([top-ga (syntax->list #'(generic-args ...))])
-                        (let loop ([ga top-ga]
-                                   [i 0])
-                          (syntax-case ga ()
-                            [(keyword id . ga)
-                             (and (keyword-stx? #'keyword)
-                                  (identifier? #'id))
-                             (loop #'ga i)]
-                            [(id . ga)
-                             (and (identifier? #'id))
-                             (if (free-identifier=? #'header #'id)
-                                 i
-                                 (loop #'ga (add1 i)))]
-                            [(keyword [id] . ga)
-                             (and (keyword-stx? #'keyword)
-                                  (identifier? #'id))
-                             (loop #'ga i)]
-                            [([id] . ga)
-                             (and (identifier? #'id))
-                             (loop #'ga i)]
-                            [_
-                             (identifier? #'id)
-                             (raise-syntax-error #f "No required by-position generic argument" top-ga)])))]
-                     [(fake-args ...)
-                      (for/list ([ga (syntax->list #'(generic-args ...))])
-                        (let loop ([ga ga])
-                          (syntax-case ga ()
-                            [(keyword id . ga)
-                             (and (keyword-stx? #'keyword)
-                                  (identifier? #'id))
-                             #`(keyword id . #,(loop #'ga))]
-                            [(id . ga)
-                             (and (identifier? #'id))
-                             #`(id . #,(loop #'ga))]
-                            [(keyword [id] . ga)
-                             (and (keyword-stx? #'keyword)
-                                  (identifier? #'id))
-                             #`(keyword [id #f] . #,(loop #'ga))]
-                            [([id] . ga)
-                             (and (identifier? #'id))
-                             #`([id #f] . #,(loop #'ga))]
-                            [id
-                             (identifier? #'id)
-                             #'id]
-                            [()
-                             #'()])))]
-                     ;; for each generic method, builds a cond clause to do the
-                     ;; predicate dispatch found in method-impl-list
-                     [((cond-impl ...) ...) marked-generics]
-                     [(-name?) (generate-temporaries #'(name?))])
-         #`(begin
-             (define-syntax name (list #'prop:name #'generic ...))
-             ; XXX optimize no kws or opts
-             (define generic-arity-coerce
-               (let*-values ([(p) (lambda fake-args #f)]
-                             [(generic-arity-spec) (procedure-arity p)]
-                             [(generic-required-kws generic-allowed-kws) (procedure-keywords p)])
-                 (lambda (method-name f)
-                   (unless (procedure? f)
-                     (raise-arguments-error
-                      'name
-                      "generic method definition is not a function"
-                      "method" method-name
-                      "given" f))
-                   (unless (arity-includes? (procedure-arity f) generic-arity-spec)
-                     (raise-arguments-error
-                      'name
-                      "method definition has an incorrect arity"
-                      "method" method-name
-                      "given arity" (procedure-arity f)
-                      "expected arity" generic-arity-spec))
-                   (procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws))))
-             ...
-             (define-values (prop:name -name? get-generics)
-               (make-struct-type-property
-                'name
-                (lambda (generic-vector si)
-                  (unless (vector? generic-vector)
-                    (error 'name
-                           "bad generics table, expecting a vector, got ~e"
-                           generic-vector))
-                  (unless (= (vector-length generic-vector)
-                             how-many-generics)
-                    (error 'name
-                           "bad generics table, expecting a vector of length ~e, got ~e"
-                           how-many-generics
-                           (vector-length generic-vector)))
-                  (vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
-                            (and mthd-generic
-                                 (generic-arity-coerce 'generic mthd-generic)))
-                          ...))
-                null #t))
-             ;; overrides the interface predicate so that any of the default
-             ;; types also answer #t
-             (define (name? x)
-               (or (-name? x) (pred? x) ...))
-             ;; Hash table mapping method name symbols to
-             ;; whether the given method is implemented
-             (define (defined-table this)
-               (unless (name? this)
-                 (raise-argument-error 'defined-table name-str this))
-               (for/hash ([name (in-list '(#,@(map syntax->datum generics)))]
-                          [gen (in-vector (get-generics this))])
-                 (values name (not (not gen)))))
-             ;; Define default implementations
-             #,@method-impl-list
-             ;; Define generic functions
-             (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))
-                   (cond
-                    [(-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)))]
-                    ;; default cases
-                    [(pred? this) (keyword-apply cond-impl kws kws-args given-args)]
-                    ...
-                    [else (raise-argument-error 'generic name-str this)])))))
-             ...)))]))
 
+  (define (free-id-table) (make-free-identifier-mapping))
+  (define (free-id-ref table id default)
+    (free-identifier-mapping-get table id (lambda () default)))
+  (define (free-id-set! table id value)
+    (free-identifier-mapping-put! table id value)))
+
+(define-syntax (define-primitive-generics/derived stx)
+  (syntax-case stx ()
+    [(_ original
+        (self-name generic-name property-name accessor-name predicate-name
+                   #:defined-table supported-name
+                   #:defaults ([default-pred default-defn ...] ...))
+        [method-name . method-signature]
+        ...)
+     (parameterize ([current-syntax-context #'original])
+       (check-identifier! #'generic-name)
+       (check-identifier! #'predicate-name)
+       (check-identifier! #'property-name)
+       (check-identifier! #'accessor-name)
+       (check-identifier! #'supported-name)
+       (check-identifier! #'self-name)
+       (define methods (syntax->list #'(method-name ...)))
+       (for-each check-identifier! methods)
+       (define n (length methods))
+       (define method-indices (for/list ([i (in-range n)]) i))
+       (define/with-syntax size n)
+       (define/with-syntax [method-index ...] method-indices)
+       (define/with-syntax contract-str
+         (format "~s" (syntax-e #'predicate-name)))
+       (define/with-syntax (default-pred-name ...)
+         (generate-temporaries #'(default-pred ...)))
+       (define/with-syntax (default-impl-name ...)
+         (generate-temporaries #'(default-pred ...)))
+       #'(begin
+           (define-syntax generic-name
+             (make-generic-info (quote-syntax property-name)
+                                (list (quote-syntax method-name) ...)))
+           (define (prop:guard x info)
+             (unless (and (vector? x) (= (vector-length x) 'size))
+               (raise-argument-error 'generic-name
+                                     (format "expected a vector of length ~a"
+                                             'size)
+                                     x))
+             (check-generic-method generic-name
+                                   method-name
+                                   method-signature
+                                   (vector-ref x 'method-index)
+                                   original)
+             ...
+             x)
+           (define-values (property-name prop:pred accessor-name)
+             (make-struct-type-property 'generic-name prop:guard '() #t))
+           (define (predicate-name self-name)
+             (or (prop:pred self-name) (default-pred-name self-name) ...))
+           (define (table-name self-name [who 'table-name])
+             (cond
+               [(prop:pred self-name) (accessor-name self-name)]
+               [(default-pred-name self-name) default-impl-name]
+               ...
+               [else (raise-argument-error who 'contract-str self-name)]))
+           (define-values (default-pred-name ...)
+             (values default-pred ...))
+           (define default-impl-name
+             (generic-method-table generic-name default-defn ...))
+           ...
+           (define-generic-support supported-name
+                                   self-name
+                                   [method-name ...]
+                                   (table-name self-name 'supported-name)
+                                   original)
+           (define-generic-method
+             method-name
+             method-signature
+             self-name
+             (vector-ref (table-name self-name 'method-name) 'method-index)
+             original)
+           ...))]))
+
+(define-syntax (define-primitive-generics stx)
+  (syntax-case stx ()
+    [(_ . args)
+     #`(define-primitive-generics/derived #,stx . args)]))
+
+(define-syntax (define-generic-support stx)
+  (syntax-case stx ()
+    [(_ supported-name
+        self-name
+        [method-name ...]
+        table
+        original)
+     (parameterize ([current-syntax-context #'original])
+       (check-identifier! #'supported-name)
+       (check-identifier! #'self-name)
+       (for-each check-identifier! (syntax->list #'(method-name ...)))
+       (define/with-syntax (index ...)
+         (for/list ([idx (in-naturals)]
+                    [stx (in-list (syntax->list #'(method-name ...)))])
+           idx))
+       #'(define (supported-name self-name)
+           (define v table)
+           (make-immutable-hasheqv
+             (list (cons 'method-name (vector-ref v 'index)) ...))))]))
+
+(begin-for-syntax
+
+  (define (method-formals/application name-stx proc-stx self-id sig-stx)
+
+    (define (check-method-signature!)
+      (define dup (check-duplicate-identifier ids))
+      (when dup (wrong-syntax dup "duplicate method argument"))
+      (for ([id (in-list non-req)]
+            #:when (free-identifier=? id self-id))
+        (wrong-syntax id
+                      "the generic name must be used as ~a"
+                      "a required, by-position argument"))
+      (define matches
+        (for/list ([id (in-list req)]
+                   #:when (free-identifier=? id self-id))
+          id))
+      (unless (pair? matches)
+        (wrong-syntax sig-stx
+                      "did not find ~a among ~a to ~s"
+                      "the generic name"
+                      "the required, by-position arguments"
+                      (syntax-e name-stx)))
+      (when (pair? (cdr matches))
+        (wrong-syntax (cadr matches)
+                      "found ~a among the arguments to ~s"
+                      "more than one occurrence of the generic name"
+                      (syntax-e name-stx))))
+
+    (define (method-formals)
+      (define/with-syntax [req-name ...] req)
+      (define/with-syntax [opt-name ...] opt)
+      (define/with-syntax ([req-arg ...] ...) req-kw)
+      (define/with-syntax ([opt-key opt-val] ...) opt-kw)
+      (define/with-syntax ([opt-arg ...] ...)
+        #'([opt-key [opt-val default-arg]] ...))
+      (define/with-syntax tail (or rest '()))
+      #'(req-name ...
+         [opt-name default-arg] ...
+         req-arg ... ...
+         opt-arg ... ...
+         . tail))
+
+    (define (method-application)
+      (define app-count (* (add1 (length opt)) (expt 2 (length opt-kw))))
+      (if (<= app-count app-threshold)
+          (by-position req opt rest
+                       (lambda (pos tail)
+                         (by-keyword req-kw opt-kw
+                                     (lambda (keys vals)
+                                       (make-application pos keys vals tail)))))
+          (brute-force-application)))
+
+    (define app-threshold 64)
+
+    (define (brute-force-application)
+      (define/with-syntax [r ...] req)
+      (define/with-syntax [o ...] opt)
+      (define/with-syntax ([key val] ...)
+        (sort (append req-kw opt-kw) keyword<?
+              #:key (compose syntax-e stx-car)))
+      (define/with-syntax tail (if rest rest #'(quote ())))
+      (define/with-syntax f proc-stx)
+      (define/with-syntax [tmp.ks tmp.vs tmp.k tmp.v tmp.args tmp.arg]
+        (generate-temporaries '(ks vs k v args arg)))
+      #'(let ()
+          (define-values (tmp.ks tmp.vs)
+            (for/lists
+                (tmp.ks tmp.vs)
+                ([tmp.k (in-list '(key ...))]
+                 [tmp.v (in-list (list val ...))]
+                 #:unless (eq? tmp.v default-arg))
+              (values tmp.k tmp.v)))
+          (define tmp.args
+            (for/list ([tmp.arg (in-list (list* o ... tail))]
+                       #:unless (eq? tmp.arg default-arg))
+              tmp.arg))
+          (keyword-apply f tmp.ks tmp.vs r ... tmp.args)))
+
+    (define (push lst x) (append lst (list x)))
+
+    (define (by-position req opt tail make-app)
+      (cond
+        [tail #`(if (pair? #,tail)
+                    #,(make-app (append req opt) tail)
+                    #,(by-position req opt #f make-app))]
+        [(null? opt) (make-app req tail)]
+        [else
+         (define/with-syntax arg (car opt))
+         #`(if (eq? arg default-arg)
+               #,(make-app req #f)
+               #,(by-position (push req (car opt)) (cdr opt) tail make-app))]))
+
+    (define (by-keyword req opt make-app)
+      (cond
+        [(null? opt) (make-app (map car req) (map cadr req))]
+        [else
+         (define/with-syntax arg (cadr (car opt)))
+         #`(if (eq? arg default-arg)
+               #,(by-keyword req (cdr opt) make-app)
+               #,(by-keyword (push req (car opt)) (cdr opt) make-app))]))
+
+    (define (make-application pos keys vals tail)
+      (define/with-syntax f proc-stx)
+      (define/with-syntax [arg ...] pos)
+      (define/with-syntax ([kw ...] ...) (map list keys vals))
+      (define/with-syntax x (generate-temporary 'x))
+      (if tail
+          (with-syntax ([rest tail])
+            #'(apply f kw ... ... arg ... rest))
+          #'(f kw ... ... arg ...)))
+
+    (define-values (req req-kw opt opt-kw rest)
+      (parse-method-signature sig-stx))
+    (define req-kw-ids (map cadr req-kw))
+    (define opt-kw-ids (map cadr opt-kw))
+    (define rest-ids (if rest (list rest) '()))
+    (define non-req (append opt req-kw-ids opt-kw-ids rest-ids))
+    (define ids (append req non-req))
+
+    (check-method-signature!)
+    (list (method-formals)
+          (method-application)))
+
+  (define (parse-method-signature stx)
+    (syntax-case stx ()
+      [(kw [val] . args)
+       (and (keyword-stx? #'kw) (identifier? #'val))
+       (let-values ([(req req-kw opt opt-kw rest)
+                     (parse-method-signature #'args)])
+         (values req req-kw opt (cons (list #'kw #'val) opt-kw) rest))]
+      [(kw val . args)
+       (and (keyword-stx? #'kw) (identifier? #'val))
+       (let-values ([(req req-kw opt opt-kw rest)
+                     (parse-method-signature #'args)])
+         (values req (cons (list #'kw #'val) req-kw) opt opt-kw rest))]
+      [(kw other . args)
+       (keyword-stx? #'kw)
+       (wrong-syntax #'other
+                     "expected required or optional identifier")]
+      [(kw . args)
+       (keyword-stx? #'kw)
+       (wrong-syntax #'kw
+                     "expected a required or optional identifier following ~s"
+                     (syntax-e #'kw))]
+      [([val] . args)
+       (identifier? #'val)
+       (let-values ([(req req-kw opt opt-kw rest)
+                     (parse-method-signature #'args)])
+         (when (pair? req)
+           (wrong-syntax (car req)
+                         "required arguments must precede optional arguments"))
+         (values req req-kw (cons #'val opt) opt-kw rest))]
+      [(val . args)
+       (identifier? #'val)
+       (let-values ([(req req-kw opt opt-kw rest)
+                     (parse-method-signature #'args)])
+         (values (cons #'val req) req-kw opt opt-kw rest))]
+      [(other . args)
+       (wrong-syntax #'other
+                     "expected a keyword or a required or optional identifier")]
+      [rest (identifier? #'rest) (values '() '() '() '() #'rest)]
+      [() (values '() '() '() '() #f)]
+      [other
+       (wrong-syntax #'other
+                     "expected an identifier or an empty list")])))
+
+(define default-arg
+  (gensym 'default-arg))
+
+(define-syntax (define-generic-method stx)
+  (syntax-case stx ()
+    [(_ method-name
+        method-signature
+        self-name
+        proc
+        original)
+     (parameterize ([current-syntax-context #'original])
+       (check-identifier! #'method-name)
+       (check-identifier! #'self-name)
+       (define/with-syntax proc-name (generate-temporary #'method-name))
+       (define/with-syntax [method-formals method-apply]
+         (method-formals/application #'method-name
+                                     #'proc-name
+                                     #'self-name
+                                     #'method-signature))
+       #'(define (method-name . method-formals)
+           (define proc-name proc)
+           (unless proc-name
+             (raise-arguments-error 'method-name
+                                    (format "not implemented for ~e"
+                                            self-name)))
+           method-apply))]))
+
+(define-syntax (check-generic-method stx)
+  (syntax-case stx ()
+    [(check-generic-method
+       generic-name
+       method-name
+       method-signature
+       method-expr
+       original)
+     (parameterize ([current-syntax-context #'original])
+       (check-identifier! #'generic-name)
+       (check-identifier! #'method-name)
+       (define-values (req req-kw opt opt-kw rest)
+         (parse-method-signature #'method-signature))
+       (define/with-syntax req-n (length req))
+       (define/with-syntax opt-n (length opt))
+       (define/with-syntax rest? (identifier? rest))
+       (define/with-syntax [req-key ...]
+         (sort (map car req-kw) keyword<? #:key syntax-e))
+       (define/with-syntax [opt-key ...]
+         (sort (map car opt-kw) keyword<? #:key syntax-e))
+       #'(check-method 'generic-name
+                       'method-name
+                       method-expr
+                       'req-n
+                       'opt-n
+                       'rest?
+                       '(req-key ...)
+                       '(opt-key ...)))]))
+
+(define (check-method who what v req-n opt-n rest? req-kws opt-kws)
+  (when v
+
+    (unless (procedure? v)
+      (define msg "generic method definition is not a function")
+      (raise-arguments-error who msg (format "~s" what) v))
+
+    (define (arity-error why)
+      (define msg
+        (format "generic method definition has an incorrect arity; ~a" why))
+      (raise-arguments-error who msg (format "~s" what) v))
+
+    (define arity (procedure-arity v))
+
+    (cond
+      [rest?
+       (unless (arity-includes? arity (arity-at-least req-n))
+         (arity-error
+           (format "expected a procedure that accepts ~a or more arguments"
+                   req-n)))]
+      [(zero? opt-n)
+       (unless (arity-includes? arity req-n)
+         (arity-error (format "expected a procedure that accepts ~a ~a"
+                              req-n
+                              (if (= 1 req-n) "argument" "arguments"))))]
+      [else
+       (for ([i (in-range req-n (+ req-n opt-n 1))])
+         (unless (arity-includes? arity i)
+           (arity-error (format "~a ~a required ~a and up to ~a optional ~a"
+                                "expected a procedure that accepts"
+                                req-n
+                                (if (= 1 req-n) "argument" "arguments")
+                                opt-n
+                                (if (= 1 opt-n) "argument" "arguments")))))])
+
+    (define-values (v-req-kws v-opt-kws) (procedure-keywords v))
+
+    (define (keyword-subset? xs ys)
+      (cond
+        [(null? xs) #t]
+        [(null? ys) #f]
+        [else
+         (define x (car xs))
+         (define y (car ys))
+         (cond
+           [(keyword<? x y) #f]
+           [(keyword<? y x) (keyword-subset? xs (cdr ys))]
+           [else (keyword-subset? (cdr xs) (cdr ys))])]))
+
+    (unless (and (keyword-subset? v-req-kws req-kws)
+                 (or (not v-opt-kws)
+                     (and (keyword-subset? req-kws v-opt-kws)
+                          (keyword-subset? opt-kws v-opt-kws))))
+      (define r (keywords-message #t req-kws))
+      (define o (keywords-message #f opt-kws))
+      (arity-error (format "expected a procedure that accepts ~a~a" r o)))))
+
+(define (keywords-message required? kws)
+  (cond
+    [(null? kws) (if required? "no required keyword arguments" "")]
+    [(null? (cdr kws))
+     (format "~athe ~a keyword argument ~s"
+             (if required? "" " and ")
+             (if required? "required" "optional")
+             (car kws))]
+    [(null? (cddr kws))
+     (format "~athe ~a keyword arguments ~s and ~s"
+             (if required? "" " and ")
+             (if required? "required" "optional")
+             (car kws)
+             (cadr kws))]
+    [else
+     (define strs
+       (let loop ([kws kws])
+         (cond
+           [(null? (cdr kws)) (list (format "and ~s" (car kws)))]
+           [else (cons (format "~s, " (car kws)) (loop (cdr kws)))])))
+     (format "~athe ~a keyword arguments ~a"
+             (if required? "" " and ")
+             (if required? "required" "optional")
+             (apply string-append strs))]))

racket/lib/collects/racket/stream.rkt

@@ -6,6 +6,7 @@
          "private/sequence.rkt"
          (only-in "private/stream-cons.rkt"
                   stream-cons)
+         "private/generic-methods.rkt"
          (for-syntax racket/base))
 
 (provide empty-stream
@@ -38,10 +39,10 @@
          stream-count)
 
 (define-syntax gen:stream
-  (list (quote-syntax prop:stream)
+  (make-generic-info (quote-syntax prop:stream)
-        (quote-syntax stream-empty?)
+                     (list (quote-syntax stream-empty?)
                            (quote-syntax stream-first)
-        (quote-syntax stream-rest)))
+                           (quote-syntax stream-rest))))
 
 (define-syntax stream
   (syntax-rules ()