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
#: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)

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

@ -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

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

@ -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))

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

@ -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 ...))]))

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

@ -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)

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

@ -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,10 +145,6 @@
"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
@ -179,7 +167,7 @@
;; overrides the interface predicate so that any of the default
;; types also answer #t
(define (name? x)
(or (-name? x) (pred? 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)

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

@ -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))))])))))