diff --git a/pkgs/data-lib/data/order.rkt b/pkgs/data-lib/data/order.rkt index 3c45780213..c6689899a5 100644 --- a/pkgs/data-lib/data/order.rkt +++ b/pkgs/data-lib/data/order.rkt @@ -19,7 +19,7 @@ prop:ordered-dict ordered-methods ordered-dict? - dict-def-table) + ordered-dict-supports?) #:fast-defaults () #:defaults () #:fallbacks () diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt index 6de8824e60..47e335e690 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt @@ -3,7 +3,7 @@ (require racket/generic) (define-generics numeric - #:defined-table numeric-support + #:defined-predicate numeric-supports? (decrement numeric) (is-zero? numeric) (is-even? numeric) @@ -19,19 +19,16 @@ (define (is-even?-fallback x) (cond - [(supports? x 'is-odd?) (not (is-odd? x))] + [(numeric-supports? x 'is-odd?) (not (is-odd? x))] [(is-zero? x) #true] [else (is-odd? (decrement x))])) (define (is-odd?-fallback x) (cond - [(supports? x 'is-even?) (not (is-even? x))] + [(numeric-supports? x 'is-even?) (not (is-even? x))] [(is-zero? x) #false] [else (is-even? (decrement x))])) -(define (supports? x sym) - (hash-ref (numeric-support x) sym #f)) - (struct peano-zero [] #:transparent #:methods gen:numeric diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt index e558969ac4..df2d49c862 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt @@ -21,7 +21,7 @@ (local-require racket/private/generic) (define-primitive-generics - (foo gen:foo prop:foo foo-methods foo? dummy) + (foo gen:foo prop:foo foo-methods foo? foo-supports?) #:fast-defaults ([number? (define (meth foo #:kw kw) kw)]) #:defaults () #:fallbacks () diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index 8af9387c0b..6647d105a7 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -17,6 +17,14 @@ (define (parse stx [options (hasheq)]) (syntax-case stx () + [(#:defined-predicate name . args) + (identifier? #'name) + (if (hash-ref options 'support #f) + (wrong-syntax (stx-car stx) + "duplicate #:defined-predicate specification") + (parse #'args (hash-set options 'support #'name)))] + [(#:defined-predicate . other) + (wrong-syntax (stx-car stx) "invalid #:defined-predicate specification")] [(#:defined-table name . args) (identifier? #'name) (if (hash-ref options 'table #f) @@ -69,7 +77,8 @@ (wrong-syntax #'other "expected a method identifier with formal arguments")] [() (values (hash-ref options 'methods '()) - (hash-ref options 'table generate-temporary) + (hash-ref options 'support generate-temporary) + (hash-ref options 'table #f) (hash-ref options 'fast-defaults '()) (hash-ref options 'defaults '()) (hash-ref options 'fallbacks '()) @@ -84,9 +93,9 @@ (parameterize ([current-syntax-context stx]) (unless (identifier? #'name) (wrong-syntax #'name "expected an identifier")) - (define-values (methods table fast-defaults defaults fallbacks derived) + (define-values (methods support table fasts defaults fallbacks derived) (parse #'rest)) - (define/with-syntax [fast-default ...] fast-defaults) + (define/with-syntax [fast-default ...] fasts) (define/with-syntax [default ...] defaults) (define/with-syntax [fallback ...] fallbacks) (define/with-syntax [derive ...] derived) @@ -100,17 +109,25 @@ (define/with-syntax gen-name (format-id #'name "gen:~a" #'name)) (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 support-name support) (define/with-syntax original stx) + (define/with-syntax table-defn + (if table + (with-syntax ([table-name table]) + #'(define (table-name name) + (for/hasheq ([sym (in-list '(method ...))]) + (values sym (support-name name sym))))) + #'(begin))) #'(begin (define-primitive-generics/derived original - (name gen-name prop-name get-name pred-name table-name) + (name gen-name prop-name get-name pred-name support-name) #:fast-defaults [fast-default ...] #:defaults [default ...] #:fallbacks [fallback ...] #:derive-properties [derive ...] method ...) + table-defn (define-generics-contract name pred-name get-name [method-name method-index] ...)))])) diff --git a/racket/collects/racket/private/dict.rkt b/racket/collects/racket/private/dict.rkt index 532063c930..a8e675977f 100644 --- a/racket/collects/racket/private/dict.rkt +++ b/racket/collects/racket/private/dict.rkt @@ -19,21 +19,21 @@ (define (mutable-vector? v) (and (vector? v) (not (immutable? v)))) -(define (dict-supports? who d . whats) - (unless (dict? d) - (raise-argument-error who "dict?" d)) - (define table (dict-def-table d)) - (for/or ([what (in-list whats)]) - (hash-ref table what #f))) - (define (dict-mutable? d) - (dict-supports? 'dict-mutable? d 'dict-set!)) + (unless (dict? d) + (raise-argument-error 'dict-mutable? "dict?" d)) + (dict-supports? d 'dict-set!)) (define (dict-can-remove-keys? d) - (dict-supports? 'dict-can-remove-keys? d 'dict-remove! 'dict-remove)) + (unless (dict? d) + (raise-argument-error 'dict-can-remove-keys? "dict?" d)) + (or (dict-supports? d 'dict-remove!) + (dict-supports? d 'dict-remove))) (define (dict-can-functional-set? d) - (dict-supports? 'dict-can-functional-set? d 'dict-set)) + (unless (dict? d) + (raise-argument-error 'dict-can-functional-set? "dict?" d)) + (dict-supports? d 'dict-set)) (define (dict-has-key? d k) (define not-there (gensym)) @@ -178,7 +178,7 @@ i))) (define-primitive-generics - (dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-def-table) + (dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-supports?) #:fast-defaults ([mutable-hash? (define dict-ref hash-ref) diff --git a/racket/collects/racket/private/generic-methods.rkt b/racket/collects/racket/private/generic-methods.rkt index 68481592f3..047e043320 100644 --- a/racket/collects/racket/private/generic-methods.rkt +++ b/racket/collects/racket/private/generic-methods.rkt @@ -6,6 +6,7 @@ (#%provide define/generic generic-property + generic-methods generic-method-table (for-syntax generic-info? make-generic-info @@ -72,11 +73,11 @@ [(_ gen) (generic-info-property (get-info 'generic-property stx #'gen))])) - (define-syntax (generic-method-table stx) + (define-syntax (generic-methods stx) (syntax-case stx () [(_ gen def ...) (let () - (define info (get-info 'generic-method-table stx #'gen)) + (define info (get-info 'generic-methods stx #'gen)) (define delta (syntax-local-make-delta-introducer #'gen)) (define methods (map delta (generic-info-methods info))) (with-syntax ([(method ...) methods]) @@ -86,7 +87,12 @@ ([(method) (make-unimplemented 'method)] ...) () def ... - (vector (implementation method) ...))))))])) + (values (implementation method) ...))))))])) + + (define-syntax (generic-method-table stx) + (syntax-case stx () + [(_ gen def ...) + #'(call-with-values (lambda () (generic-methods gen def ...)) vector)])) (define-syntax (define/generic stx) (define gen-id (syntax-parameter-value #'generic-method-context)) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index 353aa5276b..0cf6de3f3a 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -49,31 +49,43 @@ (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 fast-preds (syntax->list #'(fast-pred ...))) + (define default-preds (syntax->list #'(default-pred ...))) + (define (generate-methods . ignore) (generate-temporaries methods)) + (define (transpose-methods names) + (map cdr (apply map list methods names))) + + (define fasts-by-type (map generate-methods fast-preds)) + (define fasts-by-method (transpose-methods fasts-by-type)) + (define defaults-by-type (map generate-methods default-preds)) + (define defaults-by-method (transpose-methods defaults-by-type)) + (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 ...))) + (generate-temporaries default-preds)) (define/with-syntax (fast-pred-name ...) - (generate-temporaries #'(fast-pred ...))) - (define/with-syntax (fast-impl-name ...) - (generate-temporaries #'(fast-pred ...))) - (define/with-syntax fallback-name - (generate-temporary #'self-name)) + (generate-temporaries fast-preds)) + (define/with-syntax ([fast-by-method ...] ...) fasts-by-method) + (define/with-syntax ([fast-by-type ...] ...) fasts-by-type) + (define/with-syntax ([default-by-method ...] ...) defaults-by-method) + (define/with-syntax ([default-by-type ...] ...) defaults-by-type) + (define/with-syntax [fallback ...] (generate-methods)) (define/with-syntax forward-declaration (if (eq? (syntax-local-context) 'top-level) #'(define-syntaxes (fast-pred-name ... - fast-impl-name ... default-pred-name ... - default-impl-name ... - fallback-name) + fast-by-method ... ... + default-by-method ... ... + fallback ...) (values)) #'(begin))) + #'(begin (define-syntax generic-name (make-generic-info (quote-syntax property-name) @@ -103,74 +115,78 @@ ...) #t)) forward-declaration + (define fast-pred-name fast-pred) + ... + (define default-pred-name default-pred) + ... (define (predicate-name self-name) (or (fast-pred-name self-name) ... (prop:pred self-name) (default-pred-name self-name) ...)) - (define (table-name self-name [who 'table-name]) + (define (supported-name self-name . syms) + (define (bad-sym sym) + (raise-argument-error 'supported-name + (format "~s" '(or/c 'method-name ...)) + sym)) (cond - [(fast-pred-name self-name) fast-impl-name] + [(fast-pred-name self-name) + (for/and ([sym (in-list syms)]) + (case sym + [(method-name) (procedure? fast-by-type)] + ... + [else (bad-sym sym)]))] ... - [(prop:pred self-name) (accessor-name self-name)] - [(default-pred-name self-name) default-impl-name] + [(prop:pred self-name) + (define table (accessor-name self-name)) + (for/and ([sym (in-list syms)]) + (case sym + [(method-name) + (procedure? (vector-ref table 'method-index))] + ... + [else (bad-sym sym)]))] + [(default-pred-name self-name) + (for/and ([sym (in-list syms)]) + (case sym + [(method-name) (procedure? default-by-type)] + ... + [else (bad-sym sym)]))] ... - [else (raise-argument-error who 'contract-str self-name)])) - (define fast-pred-name fast-pred) - ... - (define default-pred-name default-pred) - ... - (define-generic-support supported-name - self-name - [method-name ...] - (table-name self-name 'supported-name) - original) + [else (raise-argument-error 'supported-name + 'contract-str + self-name)])) (define-generic-method method-name method-signature self-name - (or (vector-ref (table-name self-name 'method-name) 'method-index) - (vector-ref fallback-name 'method-index)) + (or (cond + [(fast-pred-name self-name) fast-by-method] + ... + [(prop:pred self-name) + (vector-ref (accessor-name self-name) 'method-index)] + [(default-pred-name self-name) default-by-method] + ... + [else (raise-argument-error 'method-name + 'contract-str + self-name)]) + fallback) original) ... - (define fast-impl-name - (generic-method-table generic-name fast-defn ...)) + (define-values (fast-by-type ...) + (generic-methods generic-name fast-defn ...)) ... - (define default-impl-name - (generic-method-table generic-name default-defn ...)) + (define-values (default-by-type ...) + (generic-methods generic-name default-defn ...)) ... - (define fallback-name - (generic-method-table generic-name fallback-defn ...))))])) + (define-values (fallback ...) + (generic-methods generic-name fallback-defn ...))))])) (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 - (procedure? (vector-ref v 'index))) - ...))))])) - (begin-for-syntax (define (method-formals/application name-stx proc-stx self-id sig-stx)