From e2c0b4e6427ba184e2204f4f7be96f8a09b3430e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 12 Jun 2008 17:10:31 -0400 Subject: [PATCH] Implement dmap operations. Remove lots of unneeded requires. Add in-list-forever and extend to utils.ss Add optional variable argument to c-meet. --- .../private/check-subforms-unit.ss | 17 +------ collects/typed-scheme/private/constraints.ss | 29 ++++++----- collects/typed-scheme/private/dmap.ss | 48 ++++++++++++++++++- collects/typed-scheme/private/infer-unit.ss | 19 -------- .../typed-scheme/private/promote-demote.ss | 9 ++-- .../typed-scheme/private/provide-handling.ss | 23 ++------- collects/typed-scheme/private/signatures.ss | 6 +++ collects/typed-scheme/private/tc-expr-unit.ss | 11 ----- .../typed-scheme/private/tc-lambda-unit.ss | 5 +- collects/typed-scheme/private/utils.ss | 22 ++++++++- collects/typed-scheme/typed-scheme.ss | 2 +- 11 files changed, 96 insertions(+), 95 deletions(-) diff --git a/collects/typed-scheme/private/check-subforms-unit.ss b/collects/typed-scheme/private/check-subforms-unit.ss index 55d40492c1..1658e455f1 100644 --- a/collects/typed-scheme/private/check-subforms-unit.ss +++ b/collects/typed-scheme/private/check-subforms-unit.ss @@ -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^) diff --git a/collects/typed-scheme/private/constraints.ss b/collects/typed-scheme/private/constraints.ss index e2712ae910..b016c594ca 100644 --- a/collects/typed-scheme/private/constraints.ss +++ b/collects/typed-scheme/private/constraints.ss @@ -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 diff --git a/collects/typed-scheme/private/dmap.ss b/collects/typed-scheme/private/dmap.ss index b6a49b02f6..924b86ffe7 100644 --- a/collects/typed-scheme/private/dmap.ss +++ b/collects/typed-scheme/private/dmap.ss @@ -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)))) diff --git a/collects/typed-scheme/private/infer-unit.ss b/collects/typed-scheme/private/infer-unit.ss index a162668500..68b1106217 100644 --- a/collects/typed-scheme/private/infer-unit.ss +++ b/collects/typed-scheme/private/infer-unit.ss @@ -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) diff --git a/collects/typed-scheme/private/promote-demote.ss b/collects/typed-scheme/private/promote-demote.ss index 78da49fa77..60fd33009e 100644 --- a/collects/typed-scheme/private/promote-demote.ss +++ b/collects/typed-scheme/private/promote-demote.ss @@ -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) diff --git a/collects/typed-scheme/private/provide-handling.ss b/collects/typed-scheme/private/provide-handling.ss index b6df48696f..1d4f67bfd1 100644 --- a/collects/typed-scheme/private/provide-handling.ss +++ b/collects/typed-scheme/private/provide-handling.ss @@ -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 diff --git a/collects/typed-scheme/private/signatures.ss b/collects/typed-scheme/private/signatures.ss index 49be30fc8a..c4037802d1 100644 --- a/collects/typed-scheme/private/signatures.ss +++ b/collects/typed-scheme/private/signatures.ss @@ -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^ diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/private/tc-expr-unit.ss index 05ceccd1bd..ec0f5dbe16 100644 --- a/collects/typed-scheme/private/tc-expr-unit.ss +++ b/collects/typed-scheme/private/tc-expr-unit.ss @@ -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)) diff --git a/collects/typed-scheme/private/tc-lambda-unit.ss b/collects/typed-scheme/private/tc-lambda-unit.ss index bcb79ee56e..ddb2ff8e78 100644 --- a/collects/typed-scheme/private/tc-lambda-unit.ss +++ b/collects/typed-scheme/private/tc-lambda-unit.ss @@ -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")) diff --git a/collects/typed-scheme/private/utils.ss b/collects/typed-scheme/private/utils.ss index 37638b33c9..c582bb0e86 100644 --- a/collects/typed-scheme/private/utils.ss +++ b/collects/typed-scheme/private/utils.ss @@ -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)))))) \ No newline at end of file + (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)))) \ No newline at end of file diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 939c49d5c4..f01ba63bc5 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -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"