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-> [read (cl->
[(-Port) -Sexp] [(-Port) -Sexp]
[() -Sexp])] [() -Sexp])]
[ormap (-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 b) (->... (list (->... (list a) (b b) B) (-lst a)) ((-lst b) b) B))] [andmap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
[newline (cl-> [() -Void] [newline (cl-> [() -Void]
[(-Port) -Void])] [(-Port) -Void])]
[not (-> Univ B)] [not (-> Univ B)]
@ -256,8 +256,8 @@
[(-Pathlike (-> a) Sym) a]))] [(-Pathlike (-> a) Sym) a]))]
[random (cl-> [random (cl->
[(N) N] [(-Integer) -Integer]
[() N])] [() -Integer])]
[assoc (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))] [assoc (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
[assf (-poly (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) (define-syntax (define-typed-struct stx)
(syntax-case stx (:) (syntax-case stx (:)
[(_ nm ([fld : ty] ...) . opts) [(_ nm ([fld : ty] ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts)) (let ([mutable (if (memq '#:mutable (syntax->datum #'opts))
'typechecker:ignore #t)] '(#:mutable)
[dtsi (internal (syntax/loc stx (define-typed-struct-internal nm ([fld : ty] ...))))]) '())])
#'(begin d-s dtsi))] (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) [(_ (vars ...) nm ([fld : ty] ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts)) (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fld ...) . opts))
'typechecker:ignore #t)] 'typechecker:ignore #t)]

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

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

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

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