From e3743b446cfcf842ec5060af83078343f90afa25 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 2 Sep 2012 00:11:35 -0700 Subject: [PATCH] Split adding the struct type and the bindings. --- .../typed-racket/typecheck/tc-structs.rkt | 25 ++++++++--- .../typed-racket/typecheck/tc-toplevel.rkt | 45 ++++++++++++++----- 2 files changed, 54 insertions(+), 16 deletions(-) diff --git a/collects/typed-racket/typecheck/tc-structs.rkt b/collects/typed-racket/typecheck/tc-structs.rkt index c8c3fbbdfe..aa61c39560 100644 --- a/collects/typed-racket/typecheck/tc-structs.rkt +++ b/collects/typed-racket/typecheck/tc-structs.rkt @@ -25,7 +25,9 @@ (require (for-template racket/base "internal-forms.rkt")) -(provide tc/struct names-of-struct d-s) +(provide tc/struct names-of-struct d-s + register-parsed-struct-sty! + register-parsed-struct-bindings!) (define-syntax-class parent #:attributes (name par) @@ -64,6 +66,7 @@ ((or (Poly? parent) (Mu? parent) (Struct? parent)) parent) (else + (displayln parent0) (tc-error/stx #'v.par "parent type not a valid structure name: ~a" (syntax->datum #'v.par)))))]) (values #'v.name parent0 parent)) @@ -185,6 +188,20 @@ (add-struct-fn! s (make-StructPE poly-base i) #t) (register-type s (poly-wrapper (->* (list poly-base t) -Void)))))) +(struct parsed-struct (names desc sty type-only) #:transparent) + +(define (register-parsed-struct-sty! ps) + (match ps + ((parsed-struct sty names desc type-only) + (register-sty! sty names desc)))) + +(define (register-parsed-struct-bindings! ps) + (match ps + ((parsed-struct sty names desc type-only) + (unless type-only + (register-struct-bindings! sty names desc))))) + + ;; check and register types for a define struct ;; tc/struct : Listof[identifier] (U identifier (list identifier identifier)) ;; Listof[identifier] Listof[syntax] @@ -227,11 +244,7 @@ (and proc-ty (parse-type proc-ty)))) (define sty (mk/inner-struct-type names desc concrete-parent)) - - (register-sty! sty names desc) - ;; Register the struct bindings. - (unless type-only - (register-struct-bindings! sty names desc))) + (parsed-struct sty names desc type-only)) ;; register a struct type diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index db2d0522b5..474c48ccb7 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -56,6 +56,25 @@ #:attr type-only (attribute fields.type-only) #:attr maker (attribute fields.maker))) +(define (parse-define-struct-internal form) + (parameterize ([current-orig-stx form]) + (syntax-parse form + #:literals (values define-typed-struct-internal + define-typed-struct/exec-internal quote-syntax #%plain-app) + + ;; define-typed-struct + [(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))) + (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:proc-ty #'proc-ty)]))) + + + (define (tc-toplevel/pass1 form) @@ -108,16 +127,13 @@ (register-type #'nm mk-ty) (list (make-def-binding #'nm mk-ty)))] - ;; define-typed-struct - [(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))] + ;; define-typed-struct (handled earlier) + [(define-values () (begin (quote-syntax (define-typed-struct-internal . _)) (#%plain-app values))) + (list)] - ;; 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))) - (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:proc-ty #'proc-ty)] + ;; executable structs (handled earlier) + [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal . _)) (#%plain-app values))) + (list)] ;; predicate assertion - needed for define-type b/c or doesn't work [(define-values () (begin (quote-syntax (assert-predicate-internal ty pred)) (#%plain-app values))) @@ -275,10 +291,19 @@ define/fixup-contract?)) (do-time "Form splitting done") (for-each (compose register-type-alias parse-type-alias) type-aliases) - ;; add the struct names to the type table + ;; Add the struct names to the type table, but not with a type (for-each (compose add-type-name! names-of-struct) struct-defs) ;; resolve all the type aliases, and error if there are cycles (resolve-type-aliases parse-type) + ;; Parse and register the structure types + (define parsed-structs + (for/list ((def struct-defs)) + (define parsed (parse-define-struct-internal def)) + (register-parsed-struct-sty! parsed) + parsed)) + + ;; register the bindings of the structs + (for-each register-parsed-struct-bindings! parsed-structs) (do-time "Starting pass1") ;; do pass 1, and collect the defintions (define defs (apply append (filter list? (map tc-toplevel/pass1 forms))))