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

Cleaned up define-typed-struct-internal and require/typed.

Browse Source 
Also fixed a test for require/typed.
This commit is contained in:
Eric Dobson 2011-06-29 09:52:55 -04:00 committed by Vincent St-Amour
parent f3692eae29
commit ecaf5f40a0
3 changed files with 31 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/tests/typed-scheme/succeed/require-struct.rkt
View File

@ -12,20 +12,20 @@
(module typed typed/racket (module typed typed/racket
(require/typed 'untyped (require/typed 'untyped
(struct a ((v : Integer))) (struct a ((v : Integer)))
#;(struct (b a) ((v : String))) (struct (b a) ((v : String)))
(struct c ((v : Integer)) #:constructor-name c-maker) (struct c ((v : Integer)) #:constructor-name c-maker)
#;(struct (d c) ((v : String)) #:constructor-name d-maker) (struct (d c) ((v : String)) #:constructor-name d-maker)
(struct e ((v : Integer)) #:extra-constructor-name make-e) (struct e ((v : Integer)) #:extra-constructor-name make-e)
#;(struct (f e) ((v : String)) #:extra-constructor-name make-f)) (struct (f e) ((v : String)) #:extra-constructor-name make-f))
(a 0) (a 0)
;(b 1 "2") (b 1 "2")
(c-maker 3) (c-maker 3)
;(d-maker 4 "5") (d-maker 4 "5")
(make-e 6) (make-e 6)
;(make-f 7 "8") (make-f 7 "8")
(e 9) (e 9)
#;(f 10 "11")) (f 10 "11"))
(require 'typed) (require 'typed)

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

@ -419,10 +419,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse stx #:literals (:) (syntax-parse stx #:literals (:)
[(_ name:opt-parent ([fld : ty] ...) input-maker:constructor-term lib) [(_ name:opt-parent ([fld : ty] ...) input-maker:constructor-term lib)
(define has-parent? (and (syntax-e #'name.parent) #t))
(with-syntax* ([nm #'name.nm] (with-syntax* ([nm #'name.nm]
[parent #'name.parent] [parent #'name.parent]
[spec (if has-parent? #'(nm parent) #'nm)] [spec (if (syntax-e #'name.parent) #'(nm parent) #'nm)]
[(struct-info _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] [(struct-info _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))] [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
[maker-name (if (syntax-e #'input-maker.name) #'input-maker.name #'nm)] ;New default (corresponds to how struct works) [maker-name (if (syntax-e #'input-maker.name) #'input-maker.name #'nm)] ;New default (corresponds to how struct works)

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

@ -33,6 +33,17 @@
(define unann-defs (make-free-id-table)) (define unann-defs (make-free-id-table))
(define-splicing-syntax-class dtsi-fields
#:attributes (mutable type-only maker constructor-return predicate)
(pattern
(~seq
(~or (~optional (~and #:mutable (~bind (mutable #t))))
(~optional (~and #:type-only (~bind (type-only #t))))
(~optional (~seq #:maker maker))
(~optional (~seq #:predicate predicate))
(~optional (~seq #:constructor-return constructor-return))) ...)))
(define (tc-toplevel/pass1 form) (define (tc-toplevel/pass1 form)
(parameterize ([current-orig-stx form]) (parameterize ([current-orig-stx form])
(syntax-parse form (syntax-parse form
@ -82,43 +93,20 @@
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:mutable)) (#%plain-app values))) [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:mutable)) (#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)] (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...)
#:maker m #:constructor-return t #:predicate p)) [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) fields:dtsi-fields)) (#%plain-app values)))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
#:maker #'m #:constructor-return #'t #:predicate #'p)] #:mutable (attribute fields.mutable)
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker (attribute fields.maker)
#:maker m #:constructor-return t)) #:constructor-return (attribute fields.constructor-return)
(#%plain-app values))) #:predicate (attribute fields.predicate)
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only (attribute fields.type-only))]
#:maker #'m #:constructor-return #'t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...)
#:maker m))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
#:maker #'m)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...)
#:maker m #:mutable))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
#:maker #'m #:mutable #t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...)
#:maker m))
(#%plain-app values)))
(tc/poly-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/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))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:type-only))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #: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] ...) #:maker m)) (#%plain-app values)))
(tc/poly-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/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 (vars ...) nm ([fld : ty] ...) #:mutable)) (#%plain-app values))) [(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)] (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)))