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

Split adding the struct type and the bindings.

Browse Source
This commit is contained in:
Eric Dobson 2012-09-02 00:11:35 -07:00 committed by Sam Tobin-Hochstadt
parent 40236a3b26
commit e3743b446c
2 changed files with 54 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/typed-racket/typecheck/tc-structs.rkt
View File

@ -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

45
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -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))))