From 40236a3b267c8d9e8d44ffad752c4e6e618797e2 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 1 Sep 2012 23:27:35 -0700 Subject: [PATCH] Cleanup define-struct parsing. --- .../typed-racket/typecheck/tc-toplevel.rkt | 42 +++++++++---------- 1 file changed, 19 insertions(+), 23 deletions(-) diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index a62bcc23cb..db2d0522b5 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -43,6 +43,20 @@ (~optional (~and #:type-only (~bind (type-only #t)))) (~optional (~seq #:maker maker))) ...))) +(define-syntax-class struct-name + (pattern nm:id) + (pattern (nm:id parent:id))) + + +(define-syntax-class define-typed-struct + #:attributes (mutable type-only maker nm (tvars 1) (fld 1) (ty 1)) + (pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null))) + nm:struct-name ([fld:id : ty:expr] ...) fields:dtsi-fields) + #:attr mutable (attribute fields.mutable) + #:attr type-only (attribute fields.type-only) + #:attr maker (attribute fields.maker))) + + (define (tc-toplevel/pass1 form) (parameterize ([current-orig-stx form]) @@ -95,29 +109,11 @@ (list (make-def-binding #'nm mk-ty)))] ;; define-typed-struct - [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values))) - (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] - [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:mutable)) (#%plain-app values))) - (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)] - - [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) fields:dtsi-fields)) (#%plain-app values))) - (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) - #:mutable (attribute fields.mutable) - #:maker (attribute fields.maker) - #:type-only (attribute fields.type-only))] - - ;; define-typed-struct w/ polymorphism - [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:maker m)) (#%plain-app values))) - (tc/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/struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:mutable #t)] - [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:mutable)) (#%plain-app values))) - (tc/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/struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] - ;; error in other cases - [(define-values () (begin (quote-syntax (define-typed-struct-internal . _)) (#%plain-app values))) - (int-err "unknown structure form")] + [(define-values () (begin (quote-syntax (define-typed-struct-internal ~! . dts:define-typed-struct)) (#%plain-app values))) + (tc/struct (attribute dts.tvars) #'dts.nm (syntax->list #'(dts.fld ...)) (syntax->list #'(dts.ty ...)) + #:mutable (attribute dts.mutable) + #:maker (attribute dts.maker) + #:type-only (attribute dts.type-only))] ;; executable structs - this is a big hack [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal nm ([fld : ty] ...) proc-ty)) (#%plain-app values)))