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

more stuff works

Browse Source 
svn: r13935
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-04 00:13:54 +00:00
parent 9d0ee637c7
commit c819793a82
6 changed files with 31 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/env/type-environments.ss vendored
View File

@ -12,7 +12,7 @@
(require (prefix-in r: "../utils/utils.ss"))
(require scheme/match
(r:utils tc-utils))
(except-in (r:utils tc-utils) make-env))
;; eq? has the type of equal?, and l is an alist (with conses!)
(define-struct env (eq? l))

2
collects/typed-scheme/infer/constraints.ss
View File

@ -1,7 +1,7 @@
#lang scheme/unit
(require (except-in "../utils/utils.ss" extend))
(require (private type-effect-convenience type-utils union subtype)
(require (types convenience utils union subtype)
(rep type-rep)
(utils tc-utils)
"signatures.ss" "constraint-structs.ss"

10
collects/typed-scheme/infer/infer-unit.ss
View File

@ -1,11 +1,11 @@
#lang scheme/unit
(require (except-in "../utils/utils.ss"))
(require (rep free-variance type-rep effect-rep rep-utils)
(private type-effect-convenience union subtype remove-intersect)
(utils tc-utils)
(require (rep free-variance type-rep filter-rep rep-utils)
(types convenience union subtype remove-intersect)
(except-in (utils tc-utils) make-env)
(env type-name-env)
(except-in (private type-utils) Dotted)
(except-in (types utils) Dotted)
"constraint-structs.ss"
"signatures.ss"
(only-in (env type-environments) lookup current-tvars)
@ -100,6 +100,8 @@
(define (cgen/eff V X t s)
(match* (t s)
[(e e) (empty-cset X)]
;; FIXME - do something here
#;#;
[((Latent-Restrict-Effect: t) (Latent-Restrict-Effect: s))
(cset-meet (cgen V X t s) (cgen V X s t))]
[((Latent-Remove-Effect: t) (Latent-Remove-Effect: s))

49
collects/typed-scheme/infer/promote-demote.ss
View File

@ -1,10 +1,10 @@
#lang scheme/unit
(require "../utils/utils.ss")
(require (rep type-rep)
(private type-effect-convenience union type-utils)
(require (rep type-rep rep-utils)
(types convenience union utils)
"signatures.ss"
scheme/list)
scheme/list scheme/match)
(import)
(export promote-demote^)
@ -13,10 +13,15 @@
(for/or ([e (append* (map fv ts))])
(memq e V)))
(define (get-filters rng)
(match rng
[(Values: (list (Result: _ lf _) ...)) lf]
[(ValuesDots: (list (Result: _ lf _) ...) _ _) lf]))
(define (var-promote T V)
(define (vp t) (var-promote t V))
(define (inv t) (if (V-in? V t) Univ t))
(type-case vp T
(type-case (#:Type vp #:LatentFilter (sub-lf vp)) T
[#:F name (if (memq name V) Univ T)]
[#:Vector t (make-Vector (inv t))]
[#:Box t (make-Box (inv t))]
@ -27,19 +32,16 @@
[#:Param in out
(make-Param (var-demote in V)
(vp out))]
[#:arr dom rng rest drest kws thn els
(cond
[(apply V-in? V (append thn els))
(make-arr null (Un) Univ #f null null)]
[#:arr dom rng rest drest kws
(cond
[(apply V-in? V (get-filters rng))
(make-top-arr)]
[(and drest (memq (cdr drest) V))
(make-arr (for/list ([d dom]) (var-demote d V))
(vp rng)
(var-demote (car drest) V)
#f
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-demote kwt V)))
thn
els)]
(for/list ([k kws]) (var-demote k V)))]
[else
(make-arr (for/list ([d dom]) (var-demote d V))
(vp rng)
@ -47,15 +49,12 @@
(and drest
(cons (var-demote (car drest) V)
(cdr drest)))
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-demote kwt V)))
thn
els)])]))
(for/list ([k kws]) (var-demote k V)))])]))
(define (var-demote T V)
(define (vd t) (var-demote t V))
(define (inv t) (if (V-in? V t) (Un) t))
(type-case vd T
(type-case (#:Type vd #:LatentFilter (sub-lf vd)) T
[#:F name (if (memq name V) (Un) T)]
[#:Vector t (make-Vector (inv t))]
[#:Box t (make-Box (inv t))]
@ -66,19 +65,16 @@
[#:Param in out
(make-Param (var-promote in V)
(vd out))]
[#:arr dom rng rest drest kws thn els
[#:arr dom rng rest drest kws
(cond
[(apply V-in? V (append thn els))
(make-arr null (Un) Univ #f null null)]
[(apply V-in? V (get-filters rng))
(make-top-arr)]
[(and drest (memq (cdr drest) V))
(make-arr (for/list ([d dom]) (var-promote d V))
(vd rng)
(var-promote (car drest) V)
#f
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-promote kwt V)))
thn
els)]
(for/list ([k kws]) (var-demote k V)))]
[else
(make-arr (for/list ([d dom]) (var-promote d V))
(vd rng)
@ -86,7 +82,4 @@
(and drest
(cons (var-promote (car drest) V)
(cdr drest)))
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-promote kwt V)))
thn
els)])]))
(for/list ([k kws]) (var-demote k V)))])]))

2
collects/typed-scheme/infer/restrict.ss
View File

@ -2,7 +2,7 @@
(require "../utils/utils.ss")
(require (rep type-rep)
(private type-utils union remove-intersect subtype)
(types utils union subtype remove-intersect)
"signatures.ss"
scheme/match)

2
collects/typed-scheme/private/remove-intersect.ss → collects/typed-scheme/types/remove-intersect.ss
View File

@ -2,7 +2,7 @@
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep)
(private union subtype resolve-type type-effect-convenience type-utils)
(types union subtype resolve convenience utils)
scheme/match mzlib/trace)
(provide (rename-out [*remove remove]) overlap)