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

Implement dmap operations.

Browse Source 
Remove lots of unneeded requires.
Add in-list-forever and extend to utils.ss
Add optional variable argument to c-meet.
This commit is contained in:
Sam Tobin-Hochstadt 2008-06-12 17:10:31 -04:00
parent 49be490b51
commit e2c0b4e642
11 changed files with 96 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/typed-scheme/private/check-subforms-unit.ss
View File

@ -1,30 +1,15 @@
#lang scheme/unit
(require syntax/kerncase
syntax/struct
syntax/stx
scheme/match
"type-contract.ss"
"signatures.ss"
"tc-structs.ss"
"type-utils.ss"
"utils.ss" ;; doesn't need tests
"type-rep.ss" ;; doesn't need tests
"type-effect-convenience.ss" ;; maybe needs tests
"union.ss"
"subtype.ss" ;; has tests
"internal-forms.ss" ;; doesn't need tests
"planet-requires.ss" ;; doesn't need tests
"type-env.ss" ;; maybe needs tests
"parse-type.ss" ;; has tests
"tc-utils.ss" ;; doesn't need tests
"type-environments.ss" ;; doesn't need tests
"lexical-env.ss" ;; maybe needs tests
"type-annotation.ss" ;; has tests
"type-name-env.ss" ;; maybe needs tests
"init-envs.ss"
"effect-rep.ss"
"mutated-vars.ss")
)
(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
(export check-subforms^)

29
collects/typed-scheme/private/constraints.ss
View File

@ -1,15 +1,12 @@
#lang scheme/unit
(require "type-effect-convenience.ss" "type-rep.ss" "effect-rep.ss" "rep-utils.ss"
"free-variance.ss" "type-utils.ss" "union.ss" "tc-utils.ss" "type-name-env.ss"
"subtype.ss" "remove-intersect.ss" "utils.ss"
(require "type-effect-convenience.ss" "type-rep.ss"
"type-utils.ss" "union.ss" "tc-utils.ss"
"subtype.ss" "utils.ss"
"signatures.ss"
scheme/match
mzlib/etc
mzlib/trace
scheme/list)
scheme/match)
(import restrict^)
(import restrict^ dmap^)
(export constraints^)
@ -68,13 +65,15 @@
(define (join T U) (Un T U))
(define c-meet
(match-lambda**
[((struct c (S X T)) (struct c (S* _ T*)))
(let ([S (join S S*)] [T (meet T T*)])
(unless (subtype S T)
(fail! S T))
(make-c S X T))]))
(define (c-meet c1 c2 [var #f])
(match* (c1 c2)
[((struct c (S X T)) (struct c (S* X* T*)))
(unless (or var (eq? X X*))
(int-err "Non-matching vars in c-meet: ~a ~a" X X*))
(let ([S (join S S*)] [T (meet T T*)])
(unless (subtype S T)
(fail! S T))
(make-c S (or var X) T))]))
(define (subst-all/c sub -c)
(match -c

48
collects/typed-scheme/private/dmap.ss
View File

@ -1,6 +1,50 @@
#lang scheme/unit
(import)
(export)
(require "signatures.ss" "utils.ss" "tc-utils.ss" scheme/match)
(import constraints^)
(export dmap^)
;; map : hash mapping variable to dcon
(define-struct dmap (map))
;; fixed : Listof[c]
;; rest : option[c]
(define-struct dcon (fixed rest))
;; dcon-meet : dcon dcon -> dcon
(define (dcon-meet dc1 dc2)
(match* (dc1 dc2)
[((struct dcon (fixed1 #f)) (struct dcon (fixed2 #f)))
(unless (= (length fixed1) (length fixed2))
(fail! fixed1 fixed2))
(make-dcon
(for/list ([c1 fixed1]
[c2 fixed2])
(c-meet c1 c2 (c-X c1)))
#f)]
[((struct dcon (fixed1 #f)) (struct dcon (fixed2 rest)))
(unless (>= (length fixed1) (length fixed2))
(fail! fixed1 fixed2))
(make-dcon
(for/list ([c1 fixed1]
[c2 (in-list-forever fixed2 rest)])
(c-meet c1 c2 (c-X c1)))
#f)]
[((struct dcon (fixed1 rest)) (struct dcon (fixed2 #f)))
(dcon-meet dc2 dc1)]
[((struct dcon (fixed1 rest1)) (struct dcon (fixed2 rest2)))
(let-values ([(shorter longer srest lrest)
(if (< (length fixed1) (length fixed2))
(values fixed1 fixed2 rest1 rest2)
(values fixed2 fixed1 rest2 rest1))])
(make-dcon
(for/list ([c1 longer]
[c2 (in-list-forever shorter srest)])
(c-meet c1 c2 (c-X c1)))
(c-meet lrest srest (c-X lrest))))]))
(define (dmap-meet dm1 dm2)
(hash-union dm1 dm2
(lambda (k dc1 dc2) (dcon-meet dc1 dc2))))

19
collects/typed-scheme/private/infer-unit.ss
View File

@ -11,8 +11,6 @@
(import constraints^ promote-demote^)
(export infer^)
(define (empty-set) '())
(define current-seen (make-parameter (empty-set)))
@ -25,7 +23,6 @@
(make-cset (for/list ([(cs vs) (in-pairs (cset-maps cset))])
(cons cs (hash-set vs dbound vars)))))
;; ss and ts have the same length
(define (cgen-union V X ss ts)
;; first, we remove common elements of ss and ts
@ -279,24 +276,8 @@
(subst-gen cs R)
(cset-meet cs (cgen null X R expected))))))
;; Listof[A] Listof[B] B -> Listof[B]
;; pads out t to be as long as s
(define (extend s t extra)
(append t (build-list (- (length s) (length t)) (lambda _ extra))))
(define (infer/simple S T R)
(infer (fv/list T) S T R))
(define (i s t r)
(infer/simple (list s) (list t) r))
;; this is *definitely* not yet correct
;(trace infer cgen cset-meet* subst-gen)
;(trace cgen/arr cgen/list cset-meet)
;(trace infer/dots cset-meet)
;(trace infer subst-gen cgen)

9
collects/typed-scheme/private/promote-demote.ss
View File

@ -1,11 +1,8 @@
#lang scheme/unit
(require "type-effect-convenience.ss" "type-rep.ss" "effect-rep.ss" "rep-utils.ss"
"free-variance.ss" "type-utils.ss" "union.ss" "tc-utils.ss" "type-name-env.ss"
"subtype.ss" "remove-intersect.ss" "signatures.ss" "utils.ss"
scheme/match
mzlib/etc
mzlib/trace
(require "type-effect-convenience.ss" "type-rep.ss"
"type-utils.ss" "union.ss"
"signatures.ss"
scheme/list)
(import)

23
collects/typed-scheme/private/provide-handling.ss
View File

@ -1,28 +1,11 @@
#lang scheme/base
(require (only-in srfi/1/list s:member)
syntax/kerncase syntax/struct syntax/stx
syntax/kerncase
mzlib/trace
"type-contract.ss"
"signatures.ss"
"tc-structs.ss"
"utils.ss" ;; doesn't need tests
"type-rep.ss" ;; doesn't need tests
"type-effect-convenience.ss" ;; maybe needs tests
"union.ss"
"subtype.ss" ;; has tests
"internal-forms.ss" ;; doesn't need tests
"planet-requires.ss" ;; doesn't need tests
"type-env.ss" ;; maybe needs tests
"parse-type.ss" ;; has tests
"tc-utils.ss" ;; doesn't need tests
"type-environments.ss" ;; doesn't need tests
"lexical-env.ss" ;; maybe needs tests
"type-annotation.ss" ;; has tests
"type-name-env.ss" ;; maybe needs tests
"init-envs.ss"
"effect-rep.ss"
"mutated-vars.ss"
"type-rep.ss"
"tc-utils.ss"
"def-binding.ss")
(require (for-template scheme/base

6
collects/typed-scheme/private/signatures.ss
View File

@ -2,6 +2,11 @@
(require scheme/unit)
(provide (all-defined-out))
(define-signature dmap^
((struct dmap (map))
(struct dcon (fixed rest))
dmap-meet))
(define-signature promote-demote^
(var-promote var-demote))
@ -18,6 +23,7 @@
empty-cset
insert
cset-combine
c-meet
(struct c (S X T))))
(define-signature restrict^

11
collects/typed-scheme/private/tc-expr-unit.ss
View File

@ -2,30 +2,19 @@
(require syntax/kerncase
syntax/struct
syntax/stx
scheme/match
"type-contract.ss"
"signatures.ss"
"tc-structs.ss"
"type-utils.ss"
"utils.ss" ;; doesn't need tests
"type-rep.ss" ;; doesn't need tests
"type-effect-convenience.ss" ;; maybe needs tests
"union.ss"
"subtype.ss" ;; has tests
"internal-forms.ss" ;; doesn't need tests
"planet-requires.ss" ;; doesn't need tests
"type-env.ss" ;; maybe needs tests
"parse-type.ss" ;; has tests
"tc-utils.ss" ;; doesn't need tests
"type-environments.ss" ;; doesn't need tests
"lexical-env.ss" ;; maybe needs tests
"type-annotation.ss" ;; has tests
"type-name-env.ss" ;; maybe needs tests
"init-envs.ss"
"effect-rep.ss"
"mutated-vars.ss"
scheme/private/class-internal)
(require (for-template scheme/base scheme/private/class-internal))

5
collects/typed-scheme/private/tc-lambda-unit.ss
View File

@ -1,18 +1,17 @@
#lang scheme/unit
(require "signatures.ss"
(lib "trace.ss")
mzlib/trace
(except-in "type-rep.ss" make-arr) ;; doesn't need tests
"type-effect-convenience.ss" ;; maybe needs tests
"type-environments.ss" ;; doesn't need tests
"lexical-env.ss" ;; maybe needs tests
"type-annotation.ss" ;; has tests
"utils.ss"
(except-in "utils.ss" extend)
"type-utils.ss"
"effect-rep.ss"
"tc-utils.ss"
"union.ss"
"resolve-type.ss"
(lib "plt-match.ss")
(only-in "type-effect-convenience.ss" [make-arr* make-arr]))
(require (for-template scheme/base "internal-forms.ss"))

22
collects/typed-scheme/private/utils.ss
View File

@ -12,7 +12,9 @@
id
filter-multiple
hash-union
in-pairs)
in-pairs
in-list-forever
extend)
(define-syntax (with-syntax* stx)
(syntax-case stx ()
@ -141,4 +143,20 @@
#t
(lambda (_) (more?))
(lambda _ #t)
(lambda _ #t))))))
(lambda _ #t))))))
(define (in-list-forever seq val)
(make-do-sequence
(lambda ()
(let-values ([(more? gen) (sequence-generate seq)])
(values (lambda (e) (let ([e (if (more?) (gen) val)]) e))
(lambda (_) #t)
#t
(lambda (_) #t)
(lambda _ #t)
(lambda _ #t))))))
;; Listof[A] Listof[B] B -> Listof[B]
;; pads out t to be as long as s
(define (extend s t extra)
(append t (build-list (- (length s) (length t)) (lambda _ extra))))

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

@ -12,7 +12,7 @@
"private/tc-utils.ss"
"private/type-name-env.ss"
"private/type-alias-env.ss"
"private/utils.ss"
(except-in "private/utils.ss" extend)
(only-in "private/infer-dummy.ss" infer-param)
"private/infer.ss"
"private/type-effect-convenience.ss"