diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt index ce8252accc..8f2114aa16 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt @@ -62,3 +62,56 @@ (check-true (to-bool my-a)) (check-false (to-bool my-b))) + +(define-generics nested-stream + (nested-stream-first nested-stream) + (nested-stream-rest nested-stream) + (nested-stream-empty? nested-stream) + #:defaults + ;; list of streams, yield elements of substreams + ([(lambda (los) (and (list? los) (andmap nested-stream? los))) + (define/generic super-first nested-stream-first) + (define/generic super-rest nested-stream-rest) + (define/generic super-empty? nested-stream-empty?) + (define (nested-stream-first los) + (when (stream-empty? los) + (error 'empty!)) + (if (super-empty? (first los)) + (super-first (rest los)) + (super-first (first los)))) + (define (nested-stream-rest los) + (when (stream-empty? los) + (error 'empty!)) + (if (super-empty? (first los)) + (super-rest (rest los)) + (cons (super-rest (first los)) (rest los)))) + (define (nested-stream-empty? los) + (or (empty? los) + (and (super-empty? (first los)) + (super-empty? (rest los)))))] + ;; base case, flat list + [list? + (define nested-stream-first first) + (define nested-stream-rest rest) + (define nested-stream-empty? empty?)])) + +(module+ test + (define (nested-stream->list ns) + (if (nested-stream-empty? ns) + '() + (cons (nested-stream-first ns) + (nested-stream->list (nested-stream-rest ns))))) + + (define ns1 '()) + (define ns2 '(() ())) + (define ns3 '((1 2 3) (4 5 6))) + (define ns4 '((1 2 3) (4 5 6) ())) + (define ns5 '((1 (2 (3)) (4 (5 (6)))))) + (define ns6 '(() (4 (5 (6))))) + + (check-equal? (nested-stream->list ns1) '()) + (check-equal? (nested-stream->list ns2) '()) + (check-equal? (nested-stream->list ns3) '(1 2 3 4 5 6)) + (check-equal? (nested-stream->list ns4) '(1 2 3 4 5 6)) + (check-equal? (nested-stream->list ns5) '(1 2 3 4 5 6)) + (check-equal? (nested-stream->list ns6) '(4 5 6))) diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt index 122e2cccba..f424e29d9a 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt @@ -84,6 +84,29 @@ (define (make-wrapped n) (wrapped n)) +(struct generic-wrapped [numeric] + #:transparent + #:methods gen:numeric + [(define/generic numeric-decrement decrement) + (define/generic numeric-zero? is-zero?) + (define/generic numeric-even? is-even?) + (define/generic numeric-odd? is-odd?) + (define (decrement n) + (generic-wrapped + (numeric-decrement + (generic-wrapped-numeric n)))) + (define (is-zero? n) + (numeric-zero? + (generic-wrapped-numeric n))) + (define (is-even? n) + (numeric-even? + (generic-wrapped-numeric n))) + (define (is-odd? n) + (numeric-odd? + (generic-wrapped-numeric n)))]) +(define (make-generic-wrapped n) + (generic-wrapped (make-peano n))) + (module+ test (require rackunit rackunit/text-ui) @@ -106,4 +129,5 @@ (tests "peano" make-peano) (tests "binary" make-binary) (tests "parity" make-parity) - (tests "wrapped" make-wrapped)))) + (tests "wrapped" make-wrapped) + (tests "generic-wrapped" make-generic-wrapped)))) diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/top-level.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/top-level.rkt index 49fc6c5595..ee4d06ba39 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/top-level.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/top-level.rkt @@ -10,7 +10,14 @@ (check-not-exn (λ () (eval '(require racket/generic) ns) - (eval '(define-generics foobar [foo foobar a1]) ns) + (eval '(define-generics foobar [foo foobar a1] [bar foobar a1] + #:defaults ([keyword? + (define/generic gbar bar) + (define (bar foobar a1) (gbar a1 '#:dummy))]) + #:fallbacks [(define/generic gfoo foo) + (define (foo foobar a1) 'foo) + (define (bar foobar a1) (gfoo a1 foobar))]) + ns) (eval '(struct inst () ;; make sure `gen:foobar` doesn't cause an ;; error here diff --git a/racket/lib/collects/racket/private/generic.rkt b/racket/lib/collects/racket/private/generic.rkt index 84dc70bed6..cbadfed264 100644 --- a/racket/lib/collects/racket/private/generic.rkt +++ b/racket/lib/collects/racket/private/generic.rkt @@ -53,12 +53,21 @@ (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 ...))) + (define/with-syntax ([default-pred-name default-impl-name] ...) + (for/list ([pred-stx (in-list (syntax->list #'(default-pred ...)))] + [i (in-naturals 0)]) + (list (format-id (syntax-local-introduce #'self-name) + "~a-default-pred~a" + #'self-name + i) + (format-id (syntax-local-introduce #'self-name) + "~a-default-impl~a" + #'self-name + i)))) (define/with-syntax fallback-name - (generate-temporary #'self-name)) + (format-id (syntax-local-introduce #'self-name) + "~a-fallback" + #'self-name)) #'(begin (define-syntax generic-name (make-generic-info (quote-syntax property-name) @@ -88,11 +97,6 @@ [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 fallback-name - (generic-method-table generic-name fallback-defn ...)) (define-generic-support supported-name self-name [method-name ...] @@ -105,7 +109,12 @@ (or (vector-ref (table-name self-name 'method-name) 'method-index) (vector-ref fallback-name 'method-index)) original) - ...))])) + ... + (define default-impl-name + (generic-method-table generic-name default-defn ...)) + ... + (define fallback-name + (generic-method-table generic-name fallback-defn ...))))])) (define-syntax (define-primitive-generics stx) (syntax-case stx ()