From 8c00abbf487003fbf551da8b6065e875f119261c Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 8 Jul 2013 14:59:01 -0400 Subject: [PATCH] Removed #:prop-defined-already? option from private define-generics macro. In the few cases that used this option, the only definition needed from the private define-generics macro was gen:. This is easy to define directly without using the macro, so I have changed the code to do so and avoid redundant definitions of methods. --- pkgs/data-lib/data/order.rkt | 1 - .../racket-test/tests/generic/iterator.rkt | 33 +++++--- .../racket-test/tests/generic/pr13737.rkt | 6 -- racket/lib/collects/racket/generic.rkt | 1 - racket/lib/collects/racket/private/dict.rkt | 1 - .../lib/collects/racket/private/generic.rkt | 64 ++++++--------- racket/lib/collects/racket/stream.rkt | 77 +++++++++---------- 7 files changed, 84 insertions(+), 99 deletions(-) diff --git a/pkgs/data-lib/data/order.rkt b/pkgs/data-lib/data/order.rkt index 15ad6d68e6..71d5f3907e 100644 --- a/pkgs/data-lib/data/order.rkt +++ b/pkgs/data-lib/data/order.rkt @@ -18,7 +18,6 @@ #:defined-table dict-def-table #:defaults () ;; private version needs all kw args, in order - #:prop-defined-already? #f #:define-contract #f) (dict-iterate-least ordered-dict) (dict-iterate-greatest ordered-dict) diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt index f5d2182329..ffbc786b0a 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 racket/sequence) +(require racket/private/generic 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), @@ -31,14 +31,29 @@ (lambda (v) #t) (lambda (t v) #t)))))))))) -(define-generics (iterator gen:iterator prop:iterator iterator? - #:defined-table dummy - #:defaults () - #:prop-defined-already? iterator-accessor - #:define-contract #f) - (iterator-first iterator) - (iterator-rest iterator) - (iterator-continue? iterator)) +(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 + (list (quote-syntax prop:iterator) + (quote-syntax iterator-first) + (quote-syntax iterator-rest) + (quote-syntax iterator-continue?))) (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 be300ab13a..37be5f3d57 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt @@ -20,15 +20,9 @@ (let () (local-require racket/private/generic) - (define-values (prop:foo foo? foo-accessor) - (make-struct-type-property - 'foo - #f)) - (define-generics (foo gen:foo prop:foo foo? #:defined-table dummy #:defaults ([number? (define (meth foo #:kw kw) kw)]) - #:prop-defined-already? foo-accessor #:define-contract #f) (meth foo #:kw kw)) diff --git a/racket/lib/collects/racket/generic.rkt b/racket/lib/collects/racket/generic.rkt index 8b6626c65c..4f7cc15581 100644 --- a/racket/lib/collects/racket/generic.rkt +++ b/racket/lib/collects/racket/generic.rkt @@ -69,7 +69,6 @@ #'(define-generics/pre (name gen-name prop-name pred-name #:defined-table table-name #:defaults [default ...] - #:prop-defined-already? #f #:define-contract define-generics-contract) method ...))])) diff --git a/racket/lib/collects/racket/private/dict.rkt b/racket/lib/collects/racket/private/dict.rkt index 8012b71b50..61f5799475 100644 --- a/racket/lib/collects/racket/private/dict.rkt +++ b/racket/lib/collects/racket/private/dict.rkt @@ -7,7 +7,6 @@ #:defined-table dict-def-table #:defaults () ;; private version needs all kw args, in order - #:prop-defined-already? #f #:define-contract #f) (dict-ref dict key [default]) (dict-set! dict key val) diff --git a/racket/lib/collects/racket/private/generic.rkt b/racket/lib/collects/racket/private/generic.rkt index 17fdb361ce..c74d18f260 100644 --- a/racket/lib/collects/racket/private/generic.rkt +++ b/racket/lib/collects/racket/private/generic.rkt @@ -26,10 +26,6 @@ ([pred? impl ...] ;; TODO fallthrough? ...) - ;; are we being passed an existing struct property? If so, - ;; this kw arg is bound to the struct property accessor, and - ;; we don't define the struct property - #:prop-defined-already? defined-already? ;; Passed in by `define-generics` in racket/generic. ;; This enables us to cut the dependency on racket/contract ;; for users of this private module. Pass in #f @@ -49,7 +45,6 @@ [idxs (for/list ([i (in-naturals 0)] [_ generics]) i)] - [prop-defined-already? (syntax-e #'defined-already?)] ;; syntax introducers for each default implementation set ;; these connect the default method definitions to the ;; appropriate dispatch reference in the generic function body @@ -122,10 +117,7 @@ ;; if we're the ones defining the struct property, ;; generate a new id, otherwise use the struct property ;; accessor that we were passed - [get-generics - (if prop-defined-already? - #'defined-already? - (generate-temporary 'get-generics))] + [get-generics (generate-temporary 'get-generics)] ;; for each generic method, builds a cond clause to do the ;; predicate dispatch found in method-impl-list [((cond-impl ...) ...) marked-generics] @@ -153,33 +145,29 @@ "expected arity" generic-arity-spec)) (procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws)))) ... - #,@(if prop-defined-already? - '() ; we don't need to define it - (list - #'(begin - (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) ...))))) + (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) @@ -210,9 +198,7 @@ (lambda (kws kws-args . given-args) (define this (list-ref given-args generic-this-idx)) (cond - [#,(if prop-defined-already? - #'(name? this) - #'(-name? this)) + [(-name? this) (let ([m (vector-ref (get-generics this) generic-idx)]) (if m (keyword-apply m kws kws-args given-args) diff --git a/racket/lib/collects/racket/stream.rkt b/racket/lib/collects/racket/stream.rkt index c98a195473..c70cecdc9f 100644 --- a/racket/lib/collects/racket/stream.rkt +++ b/racket/lib/collects/racket/stream.rkt @@ -2,13 +2,11 @@ (require racket/private/generic (rename-in "private/for.rkt" - [stream-ref stream-get-generics] - [stream-empty? -stream-empty?] - [stream-first -stream-first] - [stream-rest -stream-rest]) + [stream-ref stream-get-generics]) "private/sequence.rkt" (only-in "private/stream-cons.rkt" - stream-cons)) + stream-cons) + (for-syntax racket/base)) (provide empty-stream stream-cons @@ -18,9 +16,9 @@ ;; the original sequence functions will work fine ;; for the dispatch. (the method table layout is ;; identical) - (rename-out [-stream-empty? stream-empty?] - [-stream-first stream-first] - [-stream-rest stream-rest]) + stream-empty? + stream-first + stream-rest prop:stream in-stream @@ -39,16 +37,11 @@ stream-add-between stream-count) -(define-generics (-stream gen:stream prop:stream stream? - #:defined-table defined-table - #:defaults () - #:prop-defined-already? stream-get-generics - #:define-contract #f) - ;; These three are never used for the reasons explained above. - ;; We still need the headers for clients who extend racket/stream. - (stream-empty? -stream) - (stream-first -stream) - (stream-rest -stream)) +(define-syntax gen:stream + (list (quote-syntax prop:stream) + (quote-syntax stream-empty?) + (quote-syntax stream-first) + (quote-syntax stream-rest))) (define-syntax stream (syntax-rules () @@ -63,9 +56,9 @@ (define (stream-length s) (unless (stream? s) (raise-argument-error 'stream-length "stream?" s)) (let loop ([s s] [len 0]) - (if (-stream-empty? s) + (if (stream-empty? s) len - (loop (-stream-rest s) (add1 len))))) + (loop (stream-rest s) (add1 len))))) (define (stream-ref st i) (unless (stream? st) (raise-argument-error 'stream-ref "stream?" st)) @@ -73,15 +66,15 @@ (raise-argument-error 'stream-ref "exact-nonnegative-integer?" i)) (let loop ([n i] [s st]) (cond - [(-stream-empty? s) + [(stream-empty? s) (raise-arguments-error 'stream-ref "stream ended before index" "index" i "stream" st)] [(zero? n) - (-stream-first s)] + (stream-first s)] [else - (loop (sub1 n) (-stream-rest s))]))) + (loop (sub1 n) (stream-rest s))]))) (define (stream-tail st i) (unless (stream? st) (raise-argument-error 'stream-tail "stream?" st)) @@ -90,13 +83,13 @@ (let loop ([n i] [s st]) (cond [(zero? n) s] - [(-stream-empty? s) + [(stream-empty? s) (raise-arguments-error 'stream-tail "stream ended before index" "index" i "stream" st)] [else - (loop (sub1 n) (-stream-rest s))]))) + (loop (sub1 n) (stream-rest s))]))) (define (stream-append . l) (for ([s (in-list l)]) @@ -107,19 +100,19 @@ (cond [(null? l) empty-stream] [(null? (cdr l)) (car l)] - [(-stream-empty? (car l)) (streams-append (cdr l))] + [(stream-empty? (car l)) (streams-append (cdr l))] [else (make-do-stream (lambda () #f) - (lambda () (-stream-first (car l))) - (lambda () (streams-append (cons (-stream-rest (car l)) (cdr l)))))])) + (lambda () (stream-first (car l))) + (lambda () (streams-append (cons (stream-rest (car l)) (cdr l)))))])) (define (stream-map f s) (unless (procedure? f) (raise-argument-error 'stream-map "procedure?" f)) (unless (stream? s) (raise-argument-error 'stream-map "stream?" s)) (let loop ([s s]) - (if (-stream-empty? s) + (if (stream-empty? s) empty-stream - (stream-cons (f (-stream-first s)) (loop (-stream-rest s)))))) + (stream-cons (f (stream-first s)) (loop (stream-rest s)))))) (define (stream-andmap f s) (unless (procedure? f) (raise-argument-error 'stream-andmap "procedure?" f)) @@ -150,7 +143,7 @@ (unless (procedure? f) (raise-argument-error 'stream-filter "procedure?" f)) (unless (stream? s) (raise-argument-error 'stream-filter "stream?" s)) (cond - [(-stream-empty? s) empty-stream] + [(stream-empty? s) empty-stream] [else (let ([done? #f] [empty? #f] @@ -160,13 +153,13 @@ (unless done? (let loop ([s s]) (cond - [(-stream-empty? s) + [(stream-empty? s) (set! done? #t) (set! empty? #t)] - [(f (-stream-first s)) - (set! fst (-stream-first s)) - (set! rst (stream-filter f (-stream-rest s)))] - [else (loop (-stream-rest s))])) + [(f (stream-first s)) + (set! fst (stream-first s)) + (set! rst (stream-filter f (stream-rest s)))] + [else (loop (stream-rest s))])) (set! done? #t))) (make-do-stream (lambda () (force!) empty?) (lambda () (force!) fst) @@ -175,11 +168,11 @@ (define (stream-add-between s e) (unless (stream? s) (raise-argument-error 'stream-add-between "stream?" s)) - (if (-stream-empty? s) + (if (stream-empty? s) empty-stream (stream-cons - (-stream-first s) - (let loop ([s (-stream-rest s)]) - (cond [(-stream-empty? s) empty-stream] - [else (stream-cons e (stream-cons (-stream-first s) - (loop (-stream-rest s))))]))))) + (stream-first s) + (let loop ([s (stream-rest s)]) + (cond [(stream-empty? s) empty-stream] + [else (stream-cons e (stream-cons (stream-first s) + (loop (stream-rest s))))])))))