suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed #:prop-defined-already? option from private define-generics macro.

Browse Source 
In the few cases that used this option, the only definition needed from the
private define-generics macro was gen:<name>.  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.
This commit is contained in:
Carl Eastlund 2013-07-08 14:59:01 -04:00
parent b9f2e4d541
commit 8c00abbf48
7 changed files with 84 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/data-lib/data/order.rkt
View File

@ -18,7 +18,6 @@
#:defined-table dict-def-table #:defined-table dict-def-table
#:defaults () #:defaults ()
;; private version needs all kw args, in order ;; private version needs all kw args, in order
#:prop-defined-already? #f
#:define-contract #f) #:define-contract #f)
(dict-iterate-least ordered-dict) (dict-iterate-least ordered-dict)
(dict-iterate-greatest ordered-dict) (dict-iterate-greatest ordered-dict)

33
pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #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, ;; This was designed as a higher-level interface on top of sequences,
;; but it turns out streams can do all that already (including state), ;; but it turns out streams can do all that already (including state),
@ -31,14 +31,29 @@
(lambda (v) #t) (lambda (v) #t)
(lambda (t v) #t)))))))))) (lambda (t v) #t))))))))))
(define-generics (iterator gen:iterator prop:iterator iterator? (define (iterator-first i)
#:defined-table dummy (unless (iterator? i)
#:defaults () (raise-argument-error 'iterator-first "iterator?" i))
#:prop-defined-already? iterator-accessor (define proc (vector-ref (iterator-accessor i) 0))
#:define-contract #f) (proc i))
(iterator-first iterator)
(iterator-rest iterator) (define (iterator-rest i)
(iterator-continue? iterator)) (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) (struct list-iterator (l)
#:methods gen:iterator #:methods gen:iterator

6
pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt
View File

@ -20,15 +20,9 @@
(let () (let ()
(local-require racket/private/generic) (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? (define-generics (foo gen:foo prop:foo foo?
#:defined-table dummy #:defined-table dummy
#:defaults ([number? (define (meth foo #:kw kw) kw)]) #:defaults ([number? (define (meth foo #:kw kw) kw)])
#:prop-defined-already? foo-accessor
#:define-contract #f) #:define-contract #f)
(meth foo #:kw kw)) (meth foo #:kw kw))

1
racket/lib/collects/racket/generic.rkt
View File

@ -69,7 +69,6 @@
#'(define-generics/pre (name gen-name prop-name pred-name #'(define-generics/pre (name gen-name prop-name pred-name
#:defined-table table-name #:defined-table table-name
#:defaults [default ...] #:defaults [default ...]
#:prop-defined-already? #f
#:define-contract define-generics-contract) #:define-contract define-generics-contract)
method ...))])) method ...))]))

1
racket/lib/collects/racket/private/dict.rkt
View File

@ -7,7 +7,6 @@
#:defined-table dict-def-table #:defined-table dict-def-table
#:defaults () #:defaults ()
;; private version needs all kw args, in order ;; private version needs all kw args, in order
#:prop-defined-already? #f
#:define-contract #f) #:define-contract #f)
(dict-ref dict key [default]) (dict-ref dict key [default])
(dict-set! dict key val) (dict-set! dict key val)

20
racket/lib/collects/racket/private/generic.rkt
View File

@ -26,10 +26,6 @@
([pred? impl ...] ([pred? impl ...]
;; TODO fallthrough? ;; 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. ;; Passed in by `define-generics` in racket/generic.
;; This enables us to cut the dependency on racket/contract ;; This enables us to cut the dependency on racket/contract
;; for users of this private module. Pass in #f ;; for users of this private module. Pass in #f
@ -49,7 +45,6 @@
[idxs (for/list ([i (in-naturals 0)] [idxs (for/list ([i (in-naturals 0)]
[_ generics]) [_ generics])
i)] i)]
[prop-defined-already? (syntax-e #'defined-already?)]
;; syntax introducers for each default implementation set ;; syntax introducers for each default implementation set
;; these connect the default method definitions to the ;; these connect the default method definitions to the
;; appropriate dispatch reference in the generic function body ;; appropriate dispatch reference in the generic function body
@ -122,10 +117,7 @@
;; if we're the ones defining the struct property, ;; if we're the ones defining the struct property,
;; generate a new id, otherwise use the struct property ;; generate a new id, otherwise use the struct property
;; accessor that we were passed ;; accessor that we were passed
[get-generics [get-generics (generate-temporary 'get-generics)]
(if prop-defined-already?
#'defined-already?
(generate-temporary 'get-generics))]
;; for each generic method, builds a cond clause to do the ;; for each generic method, builds a cond clause to do the
;; predicate dispatch found in method-impl-list ;; predicate dispatch found in method-impl-list
[((cond-impl ...) ...) marked-generics] [((cond-impl ...) ...) marked-generics]
@ -153,10 +145,6 @@
"expected arity" generic-arity-spec)) "expected arity" generic-arity-spec))
(procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws)))) (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) (define-values (prop:name -name? get-generics)
(make-struct-type-property (make-struct-type-property
'name 'name
@ -179,7 +167,7 @@
;; overrides the interface predicate so that any of the default ;; overrides the interface predicate so that any of the default
;; types also answer #t ;; types also answer #t
(define (name? x) (define (name? x)
(or (-name? x) (pred? x) ...))))) (or (-name? x) (pred? x) ...))
;; Hash table mapping method name symbols to ;; Hash table mapping method name symbols to
;; whether the given method is implemented ;; whether the given method is implemented
(define (defined-table this) (define (defined-table this)
@ -210,9 +198,7 @@
(lambda (kws kws-args . given-args) (lambda (kws kws-args . given-args)
(define this (list-ref given-args generic-this-idx)) (define this (list-ref given-args generic-this-idx))
(cond (cond
[#,(if prop-defined-already? [(-name? this)
#'(name? this)
#'(-name? this))
(let ([m (vector-ref (get-generics this) generic-idx)]) (let ([m (vector-ref (get-generics this) generic-idx)])
(if m (if m
(keyword-apply m kws kws-args given-args) (keyword-apply m kws kws-args given-args)

77
racket/lib/collects/racket/stream.rkt
View File

@ -2,13 +2,11 @@
(require racket/private/generic (require racket/private/generic
(rename-in "private/for.rkt" (rename-in "private/for.rkt"
[stream-ref stream-get-generics] [stream-ref stream-get-generics])
[stream-empty? -stream-empty?]
[stream-first -stream-first]
[stream-rest -stream-rest])
"private/sequence.rkt" "private/sequence.rkt"
(only-in "private/stream-cons.rkt" (only-in "private/stream-cons.rkt"
stream-cons)) stream-cons)
(for-syntax racket/base))
(provide empty-stream (provide empty-stream
stream-cons stream-cons
@ -18,9 +16,9 @@
;; the original sequence functions will work fine ;; the original sequence functions will work fine
;; for the dispatch. (the method table layout is ;; for the dispatch. (the method table layout is
;; identical) ;; identical)
(rename-out [-stream-empty? stream-empty?] stream-empty?
[-stream-first stream-first] stream-first
[-stream-rest stream-rest]) stream-rest
prop:stream prop:stream
in-stream in-stream
@ -39,16 +37,11 @@
stream-add-between stream-add-between
stream-count) stream-count)
(define-generics (-stream gen:stream prop:stream stream? (define-syntax gen:stream
#:defined-table defined-table (list (quote-syntax prop:stream)
#:defaults () (quote-syntax stream-empty?)
#:prop-defined-already? stream-get-generics (quote-syntax stream-first)
#:define-contract #f) (quote-syntax stream-rest)))
;; 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 stream (define-syntax stream
(syntax-rules () (syntax-rules ()
@ -63,9 +56,9 @@
(define (stream-length s) (define (stream-length s)
(unless (stream? s) (raise-argument-error 'stream-length "stream?" s)) (unless (stream? s) (raise-argument-error 'stream-length "stream?" s))
(let loop ([s s] [len 0]) (let loop ([s s] [len 0])
(if (-stream-empty? s) (if (stream-empty? s)
len len
(loop (-stream-rest s) (add1 len))))) (loop (stream-rest s) (add1 len)))))
(define (stream-ref st i) (define (stream-ref st i)
(unless (stream? st) (raise-argument-error 'stream-ref "stream?" st)) (unless (stream? st) (raise-argument-error 'stream-ref "stream?" st))
@ -73,15 +66,15 @@
(raise-argument-error 'stream-ref "exact-nonnegative-integer?" i)) (raise-argument-error 'stream-ref "exact-nonnegative-integer?" i))
(let loop ([n i] [s st]) (let loop ([n i] [s st])
(cond (cond
[(-stream-empty? s) [(stream-empty? s)
(raise-arguments-error 'stream-ref (raise-arguments-error 'stream-ref
"stream ended before index" "stream ended before index"
"index" i "index" i
"stream" st)] "stream" st)]
[(zero? n) [(zero? n)
(-stream-first s)] (stream-first s)]
[else [else
(loop (sub1 n) (-stream-rest s))]))) (loop (sub1 n) (stream-rest s))])))
(define (stream-tail st i) (define (stream-tail st i)
(unless (stream? st) (raise-argument-error 'stream-tail "stream?" st)) (unless (stream? st) (raise-argument-error 'stream-tail "stream?" st))
@ -90,13 +83,13 @@
(let loop ([n i] [s st]) (let loop ([n i] [s st])
(cond (cond
[(zero? n) s] [(zero? n) s]
[(-stream-empty? s) [(stream-empty? s)
(raise-arguments-error 'stream-tail (raise-arguments-error 'stream-tail
"stream ended before index" "stream ended before index"
"index" i "index" i
"stream" st)] "stream" st)]
[else [else
(loop (sub1 n) (-stream-rest s))]))) (loop (sub1 n) (stream-rest s))])))
(define (stream-append . l) (define (stream-append . l)
(for ([s (in-list l)]) (for ([s (in-list l)])
@ -107,19 +100,19 @@
(cond (cond
[(null? l) empty-stream] [(null? l) empty-stream]
[(null? (cdr l)) (car l)] [(null? (cdr l)) (car l)]
[(-stream-empty? (car l)) (streams-append (cdr l))] [(stream-empty? (car l)) (streams-append (cdr l))]
[else [else
(make-do-stream (lambda () #f) (make-do-stream (lambda () #f)
(lambda () (-stream-first (car l))) (lambda () (stream-first (car l)))
(lambda () (streams-append (cons (-stream-rest (car l)) (cdr l)))))])) (lambda () (streams-append (cons (stream-rest (car l)) (cdr l)))))]))
(define (stream-map f s) (define (stream-map f s)
(unless (procedure? f) (raise-argument-error 'stream-map "procedure?" f)) (unless (procedure? f) (raise-argument-error 'stream-map "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-map "stream?" s)) (unless (stream? s) (raise-argument-error 'stream-map "stream?" s))
(let loop ([s s]) (let loop ([s s])
(if (-stream-empty? s) (if (stream-empty? s)
empty-stream 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) (define (stream-andmap f s)
(unless (procedure? f) (raise-argument-error 'stream-andmap "procedure?" f)) (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 (procedure? f) (raise-argument-error 'stream-filter "procedure?" f))
(unless (stream? s) (raise-argument-error 'stream-filter "stream?" s)) (unless (stream? s) (raise-argument-error 'stream-filter "stream?" s))
(cond (cond
[(-stream-empty? s) empty-stream] [(stream-empty? s) empty-stream]
[else [else
(let ([done? #f] (let ([done? #f]
[empty? #f] [empty? #f]
@ -160,13 +153,13 @@
(unless done? (unless done?
(let loop ([s s]) (let loop ([s s])
(cond (cond
[(-stream-empty? s) [(stream-empty? s)
(set! done? #t) (set! done? #t)
(set! empty? #t)] (set! empty? #t)]
[(f (-stream-first s)) [(f (stream-first s))
(set! fst (-stream-first s)) (set! fst (stream-first s))
(set! rst (stream-filter f (-stream-rest s)))] (set! rst (stream-filter f (stream-rest s)))]
[else (loop (-stream-rest s))])) [else (loop (stream-rest s))]))
(set! done? #t))) (set! done? #t)))
(make-do-stream (lambda () (force!) empty?) (make-do-stream (lambda () (force!) empty?)
(lambda () (force!) fst) (lambda () (force!) fst)
@ -175,11 +168,11 @@
(define (stream-add-between s e) (define (stream-add-between s e)
(unless (stream? s) (unless (stream? s)
(raise-argument-error 'stream-add-between "stream?" s)) (raise-argument-error 'stream-add-between "stream?" s))
(if (-stream-empty? s) (if (stream-empty? s)
empty-stream empty-stream
(stream-cons (stream-cons
(-stream-first s) (stream-first s)
(let loop ([s (-stream-rest s)]) (let loop ([s (stream-rest s)])
(cond [(-stream-empty? s) empty-stream] (cond [(stream-empty? s) empty-stream]
[else (stream-cons e (stream-cons (-stream-first s) [else (stream-cons e (stream-cons (stream-first s)
(loop (-stream-rest s))))]))))) (loop (stream-rest s))))])))))