suzanne.soy/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
This commit is contained in:
Sam Tobin-Hochstadt 2010-09-08 10:46:44 -04:00
parent 6130f3551c
commit a0e77705e5
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))]) [dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))] #'(begin d-s dtsi)))]
[(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts) [(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) (let ([mutable (mutable? #'opts)])
'typechecker:ignore #t)] (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
[dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))]) 'typechecker:ignore #t)]
#'(begin d-s dtsi))])) [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))]))
(lambda (stx) (lambda (stx)
(syntax-parse stx (syntax-parse stx
[(_ nm:struct-name/new (fs:fld-spec ...) . opts) [(_ 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))]) [dtsi (quasisyntax/loc stx (dtsi* () nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
#'(begin d-s dtsi)))] #'(begin d-s dtsi)))]
[(_ (vars:id ...) nm:struct-name/new (fs:fld-spec ...) . opts) [(_ (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 (with-syntax ([d-s (syntax-property (quasisyntax/loc stx
(struct #,@(attribute nm.new-spec) (fs.fld ...) (struct #,@(attribute nm.new-spec) (fs.fld ...)
#:extra-constructor-name #,cname #:extra-constructor-name #,cname
. opts)) . opts))
'typechecker:ignore #t)] '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)))]))))) #'(begin d-s dtsi)))])))))
(define-syntax (require-typed-struct stx) (define-syntax (require-typed-struct stx)

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

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