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

Propogate #:mutable for polymorphic structs.

Browse Source 
Closes PR 11127

original commit: a0e77705e578927e5d8180e6bc811461173580ab
This commit is contained in:
Sam Tobin-Hochstadt 2010-09-08 10:46:44 -04:00
parent 4bf64acde5
commit fba3c3b9ca
3 changed files with 24 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang typed/racket
(define-struct: (A) X ([b : A]) #:mutable)
set-X-b!
(struct: (A) Foo ([x : Integer]) #:mutable)
(define x (Foo 10))
(set-Foo-x! x 100)

14
collects/typed-scheme/private/prims.rkt
View File

@ -347,10 +347,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
[dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))]
[(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))])
#'(begin d-s dtsi))]))
(let ([mutable (mutable? #'opts)])
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))]))
(lambda (stx)
(syntax-parse stx
[(_ nm:struct-name/new (fs:fld-spec ...) . opts)
@ -364,13 +365,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
[dtsi (quasisyntax/loc stx (dtsi* () nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
#'(begin d-s dtsi)))]
[(_ (vars:id ...) nm:struct-name/new (fs:fld-spec ...) . opts)
(let ([cname (datum->syntax #f (syntax-e #'nm.name))])
(let ([cname (datum->syntax #f (syntax-e #'nm.name))]
[mutable (mutable? #'opts)])
(with-syntax ([d-s (syntax-property (quasisyntax/loc stx
(struct #,@(attribute nm.new-spec) (fs.fld ...)
#:extra-constructor-name #,cname
. opts))
'typechecker:ignore #t)]
[dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname))])
[dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
#'(begin d-s dtsi)))])))))
(define-syntax (require-typed-struct stx)

7
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

@ -107,10 +107,17 @@
(#%plain-app values)))
(tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
#:maker #'m)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...)
#:maker m #:mutable))
(#%plain-app values)))
(tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
#:maker #'m #:mutable #t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
;; define-typed-struct w/ polymorphism
[(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:mutable)) (#%plain-app values)))
(tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...))) (#%plain-app values)))
(tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
;; error in other cases