From 7ab8aca79b471f33348712f176bd4bcde96f00ef Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 8 Jul 2013 19:54:03 -0400 Subject: [PATCH] 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. --- .../racket-test/tests/generic/errors.rkt | 7 +- .../tests/generic/from-unstable.rkt | 4 +- .../racket-test/tests/generic/iterator.rkt | 12 +- racket/lib/collects/racket/generic.rkt | 4 +- .../collects/racket/private/define-struct.rkt | 78 +-- .../racket/private/generic-interfaces.rkt | 14 +- .../racket/private/generic-methods.rkt | 131 ++++ .../lib/collects/racket/private/generic.rkt | 609 ++++++++++++------ racket/lib/collects/racket/stream.rkt | 9 +- 9 files changed, 598 insertions(+), 270 deletions(-) create mode 100644 racket/lib/collects/racket/private/generic-methods.rkt diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/errors.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/errors.rkt index ce0eab2a3b..f283031332 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/errors.rkt +++ b/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 () diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/from-unstable.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/from-unstable.rkt index b494a0612b..5f0c34d183 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/from-unstable.rkt +++ b/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 diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt index ffbc786b0a..dfb80b55b6 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt +++ b/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) - (quote-syntax iterator-first) - (quote-syntax iterator-rest) - (quote-syntax iterator-continue?))) + (make-generic-info (quote-syntax prop:iterator) + (list (quote-syntax iterator-first) + (quote-syntax iterator-rest) + (quote-syntax iterator-continue?)))) (struct list-iterator (l) #:methods gen:iterator diff --git a/racket/lib/collects/racket/generic.rkt b/racket/lib/collects/racket/generic.rkt index 77f167a42c..415bcc77ae 100644 --- a/racket/lib/collects/racket/generic.rkt +++ b/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 ...]) diff --git a/racket/lib/collects/racket/private/define-struct.rkt b/racket/lib/collects/racket/private/define-struct.rkt index 79c6d06640..2432998237 100644 --- a/racket/lib/collects/racket/private/define-struct.rkt +++ b/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 ...) - (define (build-method-table gen specs mthds) ; mthds is syntax - (with-syntax ([(generic ...) - specs] - [(mthd-generic ...) - (map (λ (g) (datum->syntax mthds (syntax->datum g))) - specs)]) - (quasisyntax/loc gen - (let ([mthd-generic #f] - ...) - (syntax-parameterize - ([define/generic - (lambda (stx) - (syntax-case stx (mthd-generic ...) - [(_ new-name mthd-generic) - (syntax/loc stx - (define new-name generic))] - ... - [(_ 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 + (check-exprs 2 p "argument") + (define gen-id (cadr p)) + (define gen-defs (caddr p)) + (define args (cdddr p)) + (define gen-val + (and (identifier? gen-id) + (syntax-local-value gen-id (lambda () #f)))) + (unless (generic-info? gen-val) + (bad "the first argument to the " + (car p) + " is not a name for a generics group")) + (loop (list* #'#:property + (quasisyntax/loc gen-id + (generic-property #,gen-id)) + (quasisyntax/loc gen-id + (generic-method-table #,gen-id #,@gen-defs)) + args) config nongen?)] [(eq? '#:inspector (syntax-e (car p))) diff --git a/racket/lib/collects/racket/private/generic-interfaces.rkt b/racket/lib/collects/racket/private/generic-interfaces.rkt index 8cee557eeb..d7db6c13b2 100644 --- a/racket/lib/collects/racket/private/generic-interfaces.rkt +++ b/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) - (quote-syntax equal-proc) - (quote-syntax hash-proc) - (quote-syntax hash2-proc))) + (make-generic-info (quote-syntax prop:gen:equal+hash) + (list (quote-syntax equal-proc) + (quote-syntax hash-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) - (quote-syntax write-proc))) + (make-generic-info (quote-syntax prop:gen:custom-write) + (list (quote-syntax write-proc)))) ) diff --git a/racket/lib/collects/racket/private/generic-methods.rkt b/racket/lib/collects/racket/private/generic-methods.rkt new file mode 100644 index 0000000000..68481592f3 --- /dev/null +++ b/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)))]))) diff --git a/racket/lib/collects/racket/private/generic.rkt b/racket/lib/collects/racket/private/generic.rkt index 91e31da401..332b8e84b4 100644 --- a/racket/lib/collects/racket/private/generic.rkt +++ b/racket/lib/collects/racket/private/generic.rkt @@ -1,197 +1,428 @@ #lang racket/base -(require racket/local - (for-syntax racket/base +(require (for-syntax racket/base racket/local racket/syntax - syntax/stx) - (only-in "define-struct.rkt" define/generic) + syntax/stx + syntax/boundmap) + "generic-methods.rkt" (only-in racket/function arity-includes?)) -(define-for-syntax (keyword-stx? v) - (keyword? (syntax->datum v))) +(provide define-primitive-generics + define-primitive-generics/derived + define/generic) -(provide define-primitive-generics define/generic) -(define-syntax (define-primitive-generics stx) - (syntax-case stx () ; can't use syntax-parse, since it depends on us - ;; 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)))) +(begin-for-syntax + + (define (keyword-stx? v) + (keyword? (syntax->datum v))) + + (define (check-identifier! stx) + (unless (identifier? stx) + (wrong-syntax stx "expected an identifier"))) + + (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) ... - (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)]))))) - ...)))])) + 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