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

Fixed define-generics so that predicate definitions follow method definitions.

Browse Source 
I'm not sure that #:defaults and #:fast-defaults predicates should ever refer to
methods from the same generic interface, but the behavior should be divergence
rather than an undefined variable error.
This commit is contained in:
Carl Eastlund 2013-08-16 19:46:18 -04:00
parent 49e6a71f72
commit 899d57f687
2 changed files with 25 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -45,23 +45,20 @@
(if (hash-ref options 'defaults #f)
(wrong-syntax (stx-car stx) "duplicate #:defaults specification")
(let loop ([defaults '()]
[defns (hash-ref options 'defns '())]
[clauses (reverse (syntax->list #'(clause ...)))])
(if (pair? clauses)
(syntax-case (car clauses) ()
[(pred #:dispatch disp defn ...)
(loop (cons #'[pred disp defn ...] defaults)
defns
(cdr clauses))]
[(pred defn ...)
(with-syntax ([name (generate-temporary #'pred)])
(loop (cons #'[name name defn ...] defaults)
(cons #'(define name pred) defns)
(loop (cons #'[pred #:same defn ...] defaults)
(cdr clauses)))]
[clause
(wrong-syntax #'clause "invalid #:defaults specification")])
(parse #'args
(hash-set* options 'defaults defaults 'defns defns)))))]
(hash-set* options 'defaults defaults)))))]
[(#:defaults . other)
(wrong-syntax (stx-car stx) "invalid #:defaults specification")]
[(#:fast-defaults (clause ...) . args)
@ -69,26 +66,22 @@
(wrong-syntax (stx-car stx)
"duplicate #:fast-defaults specification")
(let loop ([fast-defaults '()]
[defns (hash-ref options 'defns '())]
[clauses (reverse (syntax->list #'(clause ...)))])
(if (pair? clauses)
(syntax-case (car clauses) ()
[(pred #:dispatch disp defn ...)
(loop (cons #'[pred disp defn ...] fast-defaults)
defns
(cdr clauses))]
[(pred defn ...)
(with-syntax ([name (generate-temporary #'pred)])
(loop (cons #'[name name defn ...] fast-defaults)
(cons #'(define name pred) defns)
(loop (cons #'[pred #:same defn ...] fast-defaults)
(cdr clauses)))]
[clause
(wrong-syntax #'clause
"invalid #:fast-defaults specification")])
(parse #'args
(hash-set* options
'fast-defaults fast-defaults
'defns defns)))))]
'fast-defaults fast-defaults)))))]
[(#:fast-defaults . other)
(wrong-syntax (stx-car stx) "invalid #:fast-defaults specification")]
[(#:fallbacks [fallback ...] . args)
@ -119,7 +112,6 @@
(wrong-syntax #'other
"expected a method identifier with formal arguments")]
[() (values (hash-ref options 'methods '())
(hash-ref options 'defns '())
(hash-ref options 'support generate-temporary)
(hash-ref options 'table #f)
(hash-ref options 'fast-defaults '())
@ -137,9 +129,8 @@
(unless (identifier? #'name)
(wrong-syntax #'name "expected an identifier"))
(define-values
(methods defns support table fasts defaults fallbacks derived)
(methods support table fasts defaults fallbacks derived)
(parse #'rest))
(define/with-syntax [defn ...] defns)
(define/with-syntax [fast-default ...] fasts)
(define/with-syntax [default ...] defaults)
(define/with-syntax [fallback ...] fallbacks)
@ -165,7 +156,6 @@
(values sym (support-name name sym)))))
#'(begin)))
#'(begin
defn ...
(define-primitive-generics/derived
original
(name gen-name prop-name get-name pred-name support-name)

24
racket/collects/racket/private/generic.rkt
View File

@ -69,19 +69,35 @@
(define/with-syntax [method-index ...] method-indices)
(define/with-syntax contract-str
(format "~s" (syntax-e #'predicate-name)))
(define/with-syntax (fast-pred-name ...)
(generate-temporaries fast-preds))
(define/with-syntax (fast-disp-name ...)
(generate-temporaries #'(fast-disp ...)))
(define/with-syntax (fast-disp-expr ...)
(for/list ([stx (in-list (syntax->list #'(fast-disp ...)))]
[id (in-list (syntax->list #'(fast-pred-name ...)))])
(if (eq? (syntax-e stx) '#:same)
id
stx)))
(define/with-syntax (default-pred-name ...)
(generate-temporaries default-preds))
(define/with-syntax (default-disp-name ...)
(generate-temporaries #'(default-disp ...)))
(define/with-syntax (default-disp-expr ...)
(for/list ([stx (in-list (syntax->list #'(default-disp ...)))]
[id (in-list (syntax->list #'(default-pred-name ...)))])
(if (eq? (syntax-e stx) '#:same)
id
stx)))
(define/with-syntax ([fast-by-method ...] ...) fasts-by-method)
(define/with-syntax ([fast-by-type ...] ...) fasts-by-type)
(define/with-syntax ([default-by-method ...] ...) defaults-by-method)
(define/with-syntax ([default-by-type ...] ...) defaults-by-type)
(define/with-syntax [fallback ...] (generate-methods))
(define/with-syntax forward-declaration
(if (eq? (syntax-local-context) 'top-level)
#'(define-syntaxes (fast-pred-name ...
@ -125,10 +141,6 @@
...)
#t))
forward-declaration
(define fast-pred-name fast-pred) ...
(define fast-disp-name fast-disp) ...
(define default-pred-name default-pred) ...
(define default-disp-name default-disp) ...
(define (predicate-name self-name)
(or (fast-pred-name self-name)
...
@ -183,6 +195,10 @@
fallback)
original)
...
(define fast-pred-name fast-pred) ...
(define fast-disp-name fast-disp-expr) ...
(define default-pred-name default-pred) ...
(define default-disp-name default-disp-expr) ...
(define-values (fast-by-type ...)
(generic-methods generic-name fast-defn ...))
...