diff --git a/collects/typed-scheme/private/base-env-indexing-abs.ss b/collects/typed-scheme/private/base-env-indexing-abs.ss index 1676ca26..44587b1c 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.ss +++ b/collects/typed-scheme/private/base-env-indexing-abs.ss @@ -12,7 +12,7 @@ (only-in '#%kernel [apply kernel:apply]) scheme/promise scheme/system (only-in string-constants/private/only-once maybe-print-message) - (only-in scheme/match/runtime match:error matchable? match-equality-test) + (only-in racket/match/runtime match:error matchable? match-equality-test) (for-template scheme) (rename-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym] [-Nat -Nat*])) diff --git a/collects/typed-scheme/private/base-env-numeric.ss b/collects/typed-scheme/private/base-env-numeric.ss index de984fde..e8661438 100644 --- a/collects/typed-scheme/private/base-env-numeric.ss +++ b/collects/typed-scheme/private/base-env-numeric.ss @@ -11,7 +11,7 @@ (only-in '#%kernel [apply kernel:apply]) scheme/promise scheme/system (only-in string-constants/private/only-once maybe-print-message) - (only-in scheme/match/runtime match:error matchable? match-equality-test) + (only-in racket/match/runtime match:error matchable? match-equality-test) (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym] [-Real R] [-ExactPositiveInteger -Pos]))) (define-for-syntax all-num-types (list -Pos -Nat -Integer -ExactRational -Flonum -Real N)) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 278a9558..231f6ea8 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -12,7 +12,7 @@ scheme/promise scheme/system (only-in string-constants/private/only-once maybe-print-message) (only-in mzscheme make-namespace) - (only-in scheme/match/runtime match:error matchable? match-equality-test) + (only-in racket/match/runtime match:error matchable? match-equality-test) (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym]) (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-VectorTop))) diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss index b631a4d7..4ead72b0 100644 --- a/collects/typed-scheme/private/base-special-env.ss +++ b/collects/typed-scheme/private/base-special-env.ss @@ -7,7 +7,7 @@ (only-in scheme/list cons? take drop add-between last filter-map) (only-in rnrs/lists-6 fold-left) '#%paramz - (only-in scheme/match/runtime match:error) + (only-in racket/match/runtime match:error) scheme/promise string-constants/string-constant ;(prefix-in ce: test-engine/scheme-tests) diff --git a/collects/typed-scheme/private/with-types.ss b/collects/typed-scheme/private/with-types.ss index 06c550b6..9e0c85dd 100644 --- a/collects/typed-scheme/private/with-types.ss +++ b/collects/typed-scheme/private/with-types.ss @@ -9,7 +9,7 @@ "extra-procs.ss" "prims.ss" "base-types.ss" - scheme/contract/regions scheme/contract/base + racket/contract/regions racket/contract/base (for-syntax "base-types-extra.ss" unstable/debug diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index ecfc7a92..88eb1126 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -9,7 +9,7 @@ (private typed-renaming) (rep type-rep) (utils tc-utils) - scheme/contract/private/provide unstable/list + racket/contract/private/provide unstable/list unstable/debug unstable/syntax scheme/struct-info scheme/match "def-binding.ss" syntax/parse) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 09919656..8f501b49 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -8,7 +8,7 @@ unstable/sequence ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy scheme/bool - (only-in scheme/private/class-internal make-object do-make-object) + (only-in racket/private/class-internal make-object do-make-object) (only-in '#%kernel [apply k:apply]) ;; end fixme (for-syntax syntax/parse scheme/base (utils tc-utils)) @@ -22,7 +22,7 @@ (for-template (only-in '#%kernel [apply k:apply]) "internal-forms.ss" scheme/base scheme/bool - (only-in scheme/private/class-internal make-object do-make-object))) + (only-in racket/private/class-internal make-object do-make-object))) (import tc-expr^ tc-lambda^ tc-dots^ tc-let^) (export tc-app^) diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index bd97da2e..8a8a353d 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -69,12 +69,12 @@ (for/fold ([Γ (replace-props env imps)]) ([f atoms]) (match f [(Bot:) (set-box! flag #f) (env-map (lambda (x) (cons (car x) (Un))) Γ)] - [(ImpFilter: _ _) Γ] [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) (update-type/lexical (lambda (x t) (let ([new-t (update t f)]) (when (type-equal? new-t (Un)) (set-box! flag #f)) new-t)) - x Γ)]))) + x Γ)] + [_ Γ]))) (p/c [env+ (env? (listof Filter/c) (box/c #t). -> . env?)]) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 9d22a03c..dce2fb20 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -12,11 +12,11 @@ (except-in (utils tc-utils stxclass-util)) (env lexical-env) (only-in (env type-environments) lookup current-tvars extend-env) - scheme/private/class-internal + racket/private/class-internal (except-in syntax/parse id) (only-in srfi/1 split-at)) -(require (for-template scheme/base scheme/private/class-internal)) +(require (for-template scheme/base racket/private/class-internal)) (import tc-if^ tc-lambda^ tc-app^ tc-let^ check-subforms^) (export tc-expr^) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 38c971a1..e18bf9c9 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -91,19 +91,16 @@ (provide combine-props tc-results->values) (define (combine-props new-props old-props) - (define-values (new-atoms new-formulas) - (partition (lambda (e) (or (TypeFilter? e) (NotTypeFilter? e))) new-props)) - (values new-formulas new-atoms) - #;#; - (define-values (derived-imps derived-atoms) - (for/fold - ([derived-imps null] - [derived-atoms null]) - ([o old-props]) - (match o - [(ImpFilter: as cs) - (let ([as* (remove* new-atoms as filter-equal?)]) - (if (null? as*) - (values derived-imps (append cs new-atoms)) - (values (cons (make-ImpFilter as* cs) derived-imps) derived-atoms)))]))) - (values (append new-imps derived-imps) (append new-atoms derived-atoms))) + (define (atomic-prop? p) (or (TypeFilter? p) (NotTypeFilter? p))) + (define-values (new-atoms new-formulas) (partition atomic-prop? new-props)) + (let loop ([derived-props null] + [derived-atoms new-atoms] + [worklist (append old-props new-formulas)]) + (if (null? worklist) + (values derived-props derived-atoms) + (let ([p (car worklist)]) + (match p + [(AndFilter: ps) (loop derived-props derived-atoms (append ps (cdr worklist)))] + [(TypeFilter: _ _ _) (loop derived-props (cons p derived-atoms) (cdr worklist))] + [(NotTypeFilter: _ _ _) (loop derived-props (cons p derived-atoms) (cdr worklist))] + [_ (loop (cons p derived-props) derived-atoms (cdr worklist))])))))