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

Cleaned up define-struct: and struct:.

Browse Source 
original commit: 9721409b3994697444078d228c3208af7f484ee2
This commit is contained in:
Eric Dobson 2011-06-29 14:43:24 -04:00 committed by Vincent St-Amour
parent 00e5ce0357
commit 65638b0d8b
1 changed files with 11 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/typed-scheme/base-env/prims.rkt
View File

@ -358,26 +358,27 @@ This file defines two sorts of primitives. All of them are provided into any mod
#:with super #f
#:attr old-spec #'name
#:with new-spec #'(name)))
(define-splicing-syntax-class maybe-type-vars
#:description "optional list of type variables"
#:attributes ((vars 1))
(pattern (vars:id ...))
(pattern (~seq) #:attr (vars 1) null))
(define (mutable? opts)
(if (memq '#:mutable (syntax->datum opts)) '(#:mutable) '()))
(values
(lambda (stx)
(syntax-parse stx
[(_ nm:struct-name (fs:fld-spec ...) . opts)
[(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...) . opts)
(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* () nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))]
[(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts)
(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))])
[dtsi (quasisyntax/loc stx (dtsi* (vars.vars ...) nm (fs ...) #,@mutable))])
#'(begin d-s dtsi)))]))
(lambda (stx)
(syntax-parse stx
[(_ nm:struct-name/new (fs:fld-spec ...) . opts)
[(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...) . opts)
(let ([mutable (mutable? #'opts)]
[cname (datum->syntax #f (syntax-e #'nm.name))])
(with-syntax ([d-s (syntax-property (quasisyntax/loc stx
@ -385,17 +386,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
#:extra-constructor-name #,cname
. opts))
'typechecker:ignore #t)]
[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))]
[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 #,@mutable))])
[dtsi (quasisyntax/loc stx (dtsi* (vars.vars ...) nm.old-spec (fs ...) #:maker #,cname #,@mutable))])
#'(begin d-s dtsi)))])))))