diff --git a/pkgs/data-lib/data/order.rkt b/pkgs/data-lib/data/order.rkt index baa8ff51bd..2f65d075f2 100644 --- a/pkgs/data-lib/data/order.rkt +++ b/pkgs/data-lib/data/order.rkt @@ -22,6 +22,7 @@ dict-def-table) #:defaults () #:fallbacks () + #:derive-properties () (dict-iterate-least ordered-dict) (dict-iterate-greatest ordered-dict) (dict-iterate-least/>? ordered-dict key) diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt index dfb80b55b6..b1b5faecb9 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require racket/private/generic-methods +(require racket/generic racket/sequence (for-syntax racket/base)) @@ -8,54 +8,25 @@ ;; but it turns out streams can do all that already (including state), ;; making iterators redundant. Kept around as extra tests. - -(define-values (prop:iterator iterator? iterator-accessor) - (make-struct-type-property - 'iterator - #f - ;; Iterators are automatically sequences, but don't have the full - ;; flexibility of sequences: they are their own initial state, and - ;; they can only look at their state to decide if iteration is over. - ;; Given that extra field can be added to the iterator, there is no - ;; loss of expressiveness. - (list (cons prop:sequence - (lambda (method-table) ; 3-vector - (define iterator-first (vector-ref method-table 0)) - (define iterator-rest (vector-ref method-table 1)) - (define iterator-continue? (vector-ref method-table 2)) - (lambda (t) - (make-do-sequence - (lambda () - (values iterator-first - iterator-rest ; needs to create a new struct - t - iterator-continue? - (lambda (v) #t) - (lambda (t v) #t)))))))))) - -(define (iterator-first i) - (unless (iterator? i) - (raise-argument-error 'iterator-first "iterator?" i)) - (define proc (vector-ref (iterator-accessor i) 0)) - (proc i)) - -(define (iterator-rest i) - (unless (iterator? i) - (raise-argument-error 'iterator-rest "iterator?" i)) - (define proc (vector-ref (iterator-accessor i) 1)) - (proc i)) - -(define (iterator-continue? i) - (unless (iterator? i) - (raise-argument-error 'iterator-continue? "iterator?" i)) - (define proc (vector-ref (iterator-accessor i) 2)) - (proc i)) - -(define-syntax gen:iterator - (make-generic-info (quote-syntax prop:iterator) - (list (quote-syntax iterator-first) - (quote-syntax iterator-rest) - (quote-syntax iterator-continue?)))) +(define-generics iterator + (iterator-first iterator) + (iterator-rest iterator) + (iterator-continue? iterator) + ;; Iterators are automatically sequences, but don't have the full + ;; flexibility of sequences: they are their own initial state, and + ;; they can only look at their state to decide if iteration is over. + ;; Given that extra field can be added to the iterator, there is no + ;; loss of expressiveness. + #:derive-property prop:sequence + (lambda (t) + (make-do-sequence + (lambda () + (values iterator-first + iterator-rest ; needs to create a new struct + t + iterator-continue? + (lambda (v) #t) + (lambda (t v) #t)))))) (struct list-iterator (l) #:methods gen:iterator diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt index 6ea16cef38..f9f2f629fe 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt @@ -24,6 +24,7 @@ (foo gen:foo prop:foo foo-methods foo? dummy) #:defaults ([number? (define (meth foo #:kw kw) kw)]) #:fallbacks () + #:derive-properties () (meth foo #:kw kw)) (check-equal? (meth 3 #:kw 5) 5)) diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index 0e63794396..c98fa12f23 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -15,45 +15,54 @@ (begin-for-syntax - (define (parse stx methods table defaults fallbacks) + (define (parse stx [options (hasheq)]) (syntax-case stx () [(#:defined-table name . args) (identifier? #'name) - (if table + (if (hash-ref options 'table #f) (wrong-syntax (stx-car stx) "duplicate #:defined-table specification") - (parse #'args methods #'name defaults fallbacks))] + (parse #'args (hash-set options 'table #'name)))] [(#:defined-table . other) (wrong-syntax (stx-car stx) "invalid #:defined-table specification")] [(#:defaults ([pred defn ...] ...) . args) - (if defaults + (if (hash-ref options 'defaults #f) (wrong-syntax (stx-car stx) "duplicate #:defaults specification") - (parse #'args methods table #'([pred defn ...] ...) fallbacks))] + (parse #'args (hash-set options 'defaults #'([pred defn ...] ...))))] [(#:defaults . other) (wrong-syntax (stx-car stx) "invalid #:defaults specification")] [(#:fallbacks [fallback ...] . args) - (if fallbacks + (if (hash-ref options 'fallbacks #f) (wrong-syntax (stx-car stx) "duplicate #:fallbacks specification") - (parse #'args methods table defaults #'[fallback ...]))] + (parse #'args (hash-set options 'fallbacks #'[fallback ...])))] [(#:fallbacks . other) (wrong-syntax (stx-car stx) "invalid #:fallbacks specification")] + [(#:derive-property prop impl . args) + (parse #'args + (hash-set options + 'derived + (cons (list #'prop #'impl) + (hash-ref options 'derived '()))))] + [(#:derive-property . other) + (wrong-syntax (stx-car stx) "invalid #:derive-property specification")] [(kw . args) (keyword? (syntax-e #'kw)) (wrong-syntax #'kw "invalid keyword argument")] [((_ . _) . args) - (if methods + (if (hash-ref options 'methods #f) (wrong-syntax (stx-car stx) "duplicate methods list specification") (let loop ([methods (list (stx-car stx))] [stx #'args]) (syntax-case stx () [((_ . _) . args) (loop (cons (stx-car stx) methods) #'args)] - [_ (parse stx (reverse methods) table defaults fallbacks)])))] + [_ (parse stx (hash-set options 'methods (reverse methods)))])))] [(other . args) (wrong-syntax #'other "expected a method identifier with formal arguments")] - [() (values (or methods '()) - (or table (generate-temporary 'table)) - (or defaults '()) - (or fallbacks '()))] + [() (values (hash-ref options 'methods '()) + (hash-ref options 'table generate-temporary) + (hash-ref options 'defaults '()) + (hash-ref options 'fallbacks '()) + (hash-ref options 'derived '()))] [other (wrong-syntax #'other "expected a list of arguments with no dotted tail")]))) @@ -64,10 +73,11 @@ (parameterize ([current-syntax-context stx]) (unless (identifier? #'name) (wrong-syntax #'name "expected an identifier")) - (define-values (methods table defaults fallbacks) - (parse #'rest #f #f #f #f)) + (define-values (methods table defaults fallbacks derived) + (parse #'rest)) (define/with-syntax [default ...] defaults) (define/with-syntax [fallback ...] fallbacks) + (define/with-syntax [derive ...] derived) (define/with-syntax [method ...] methods) (define/with-syntax [method-name ...] (map stx-car methods)) (define/with-syntax [method-index ...] @@ -86,6 +96,7 @@ (name gen-name prop-name get-name pred-name table-name) #:defaults [default ...] #:fallbacks [fallback ...] + #:derive-properties [derive ...] method ...) (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 350006f1f8..89a6b3f310 100644 --- a/racket/collects/racket/private/dict.rkt +++ b/racket/collects/racket/private/dict.rkt @@ -7,6 +7,7 @@ (dict gen:dict prop:dict dict-methods dict? dict-def-table) #:defaults () #:fallbacks () + #:derive-properties () (dict-ref dict key [default]) (dict-set! dict key val) (dict-set dict key val) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index cbadfed264..91f7d3ac4f 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -36,6 +36,7 @@ supported-name) #:defaults ([default-pred default-defn ...] ...) #:fallbacks [fallback-defn ...] + #:derive-properties ([derived-prop derived-impl] ...) [method-name . method-signature] ...) (parameterize ([current-syntax-context #'original]) @@ -86,7 +87,16 @@ ... x) (define-values (property-name prop:pred accessor-name) - (make-struct-type-property 'generic-name prop:guard '() #t)) + (make-struct-type-property + 'generic-name + prop:guard + (list + (cons derived-prop + (lambda (impl) + (let ([method-name (vector-ref impl 'method-index)] ...) + derived-impl))) + ...) + #t)) (define (predicate-name self-name) (or (prop:pred self-name) (default-pred-name self-name) ...)) (define (table-name self-name [who 'table-name])