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

Fix handling of mutable structs (setters != getters)

Browse Source 
Allow use of #:mutable as define-typed-struct arg
Fix types of random andmap ormap
This commit is contained in:
Sam Tobin-Hochstadt 2008-07-13 17:31:58 -04:00
parent 4e7f527cb8
commit 2456dcc18b
4 changed files with 17 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/typed-scheme/private/base-env.ss
View File

@ -105,8 +105,8 @@
[read (cl->
[(-Port) -Sexp]
[() -Sexp])]
[ormap (-polydots (a b) (->... (list (->... (list a) (b b) B) (-lst a)) ((-lst b) b) B))]
[andmap (-polydots (a b) (->... (list (->... (list a) (b b) B) (-lst a)) ((-lst b) b) B))]
[ormap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
[andmap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
[newline (cl-> [() -Void]
[(-Port) -Void])]
[not (-> Univ B)]
@ -256,8 +256,8 @@
[(-Pathlike (-> a) Sym) a]))]
[random (cl->
[(N) N]
[() N])]
[(-Integer) -Integer]
[() -Integer])]
[assoc (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
[assf (-poly (a b)

11
collects/typed-scheme/private/prims.ss
View File

@ -305,10 +305,13 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define-syntax (define-typed-struct stx)
(syntax-case stx (:)
[(_ nm ([fld : ty] ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (internal (syntax/loc stx (define-typed-struct-internal nm ([fld : ty] ...))))])
#'(begin d-s dtsi))]
(let ([mutable (if (memq '#:mutable (syntax->datum #'opts))
'(#:mutable)
'())])
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts))
'typechecker:ignore #t)]
[dtsi (internal (quasisyntax/loc stx (define-typed-struct-internal nm ([fld : ty] ...) #,@mutable)))])
#'(begin d-s dtsi)))]
[(_ (vars ...) nm ([fld : ty] ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts))
'typechecker:ignore #t)]

7
collects/typed-scheme/private/tc-structs.ss
View File

@ -129,7 +129,7 @@
(make-pred-ty (wrapper name))))
(map (lambda (g t) (cons g (wrapper (->* (list name) t)))) getters external-fld-types/no-parent)
(if setters?
(map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) getters external-fld-types/no-parent)
(map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent)
null)))
(register-type-name nm (wrapper sty))
(for/list ([e bindings])
@ -171,7 +171,7 @@
;; typecheck a non-polymophic struct and register the approriate types
;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
(define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f])
(define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f])
;; get the parent info and create some types and type variables
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
;; parse the field types, and determine if the type is recursive
@ -186,7 +186,8 @@
;; procedure
#:proc-ty proc-ty-parsed
#:maker maker
#:constructor-return (and cret (parse-type cret))))
#:constructor-return (and cret (parse-type cret))
#:mutable mutable))
;; register a struct type
;; convenience function for built-in structs

2
collects/typed-scheme/private/tc-toplevel.ss
View File

@ -54,6 +54,8 @@
;; define-typed-struct
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values)))
(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)))
(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))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)]