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

racket/generics: fix generated <gen>/c

Browse Source 
The revised implementation of `define-generics` for the new macro
expander wasn't right, because the macro attached to `<gen>/c` for a
given `<gen>` used a macro-introduced reference to the generic to
match up method names with the generic's methods.
This commit is contained in:
Matthew Flatt 2015-07-20 06:39:18 -06:00
parent 0bc5a1b06a
commit 54cf4c7f16
2 changed files with 33 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-test/tests/generic/contract.rkt
View File

@ -51,3 +51,19 @@
(λ () (dict-set dict "bad" 5))))
(require 'c)
;; ----------------------------------------
(module contract-on-method racket
(require racket/generic)
(provide gen:foo foo? foo/c (contract-out [bar (foo? . -> . any/c)]))
(define-generics foo
(bar foo)))
(module make-generic-contract racket
(require 'contract-on-method)
(define (foo/c* c)
(foo/c
[bar (foo? . -> . c)])))

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

@ -169,7 +169,7 @@
(define-syntax (redirect-generics/derived stx)
(syntax-case stx ()
[(_ orig mode gen-name val-expr [method-name proc-expr] ... props-expr)
[(_ orig mode gen-name ref-gen-id val-expr [method-name proc-expr] ... props-expr)
(parameterize ([current-syntax-context #'orig])
(define gen-id #'gen-name)
(unless (identifier? gen-id)
@ -177,7 +177,7 @@
(define gen-info (syntax-local-value gen-id (lambda () #f)))
(unless (generic-info? gen-info)
(wrong-syntax gen-id "expected a name for a generic interface"))
(define delta (make-method-delta gen-id (generic-info-name gen-info)))
(define delta (make-method-delta #'ref-gen-id (generic-info-name gen-info)))
(define predicate (generic-info-predicate gen-info))
(define accessor (generic-info-accessor gen-info))
(define method-ids (syntax->list #'(method-name ...)))
@ -198,23 +198,23 @@
(define-syntax (redirect-generics stx)
(syntax-case stx ()
[(_ mode gen-name val-expr [id expr] ...)
#`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ... null)]
#`(redirect-generics/derived #,stx mode gen-name gen-name val-expr [id expr] ... null)]
[(_ mode gen-name val-expr [id expr] ... #:properties props-expr)
#`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ... props-expr)]))
#`(redirect-generics/derived #,stx mode gen-name gen-name val-expr [id expr] ... props-expr)]))
(define-syntax (chaperone-generics stx)
(syntax-case stx ()
[(_ gen-name val-expr [id expr] ...)
#`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ... null)]
#`(redirect-generics/derived #,stx #t gen-name gen-name val-expr [id expr] ... null)]
[(_ gen-name val-expr [id expr] ... #:properties props-expr)
#`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ... props-expr)]))
#`(redirect-generics/derived #,stx #t gen-name gen-name val-expr [id expr] ... props-expr)]))
(define-syntax (impersonate-generics stx)
(syntax-case stx ()
[(_ gen-name val-expr [id expr] ...)
#`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ... null)]
#`(redirect-generics/derived #,stx #f gen-name gen-name val-expr [id expr] ... null)]
[(_ gen-name val-expr [id expr] ... #:properties props-expr)
#`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ... props-expr)]))
#`(redirect-generics/derived #,stx #f gen-name gen-name val-expr [id expr] ... props-expr)]))
(define (redirect-generics-proc name chaperoning? pred ref x proc props)
(unless (pred x)
@ -241,10 +241,10 @@
(define-syntax-rule (define-generics-contract ctc-name gen-name)
(define-syntax (ctc-name stx)
(syntax-case stx ()
[(_ [id expr] (... ...))
[(ref-id [id expr] (... ...))
#`(generic-instance/c/derived #,stx
[ctc-name]
gen-name
gen-name ref-id
[id expr]
(... ...))])))
@ -253,13 +253,13 @@
[(_ gen-name [id expr] ...)
#`(generic-instance/c/derived #,stx
[generic-instance/c gen-name]
gen-name
gen-name gen-name
[id expr]
...)]))
(define-syntax (generic-instance/c/derived stx)
(syntax-case stx ()
[(_ original [prefix ...] gen-name [method-id ctc-expr] ...)
[(_ original [prefix ...] gen-name ref-gen-id [method-id ctc-expr] ...)
(parameterize ([current-syntax-context #'original])
(define gen-id #'gen-name)
(unless (identifier? gen-id)
@ -281,16 +281,18 @@
'(method-id ...)
(list ctc-id ...)
(lambda (b x mode)
(redirect-generics
(redirect-generics/derived
original
mode
gen-name
gen-name ref-gen-id
x
[method-id
(lambda (m)
(define b2
(blame-add-context b (format "method ~a" 'method-id)))
(((contract-projection ctc-id) b2) m))]
...)))))]))
...
null)))))]))
(define (make-generics-contract ifc pfx pred mths ctcs proc)
(define chaperoning?