diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index c520cebd..b0b3f782 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -8,7 +8,7 @@ (for-syntax scheme/base)) -(require (types comparison type-utils) +(require (types comparison utils) (schemeunit)) (provide private typecheck (rename-out [infer r:infer]) utils env rep types) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index c6064d45..2a2625d9 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -2,12 +2,12 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (types comparison type-abbrev) + (types comparison abbrev union) (schemeunit)) (provide type-equal-tests) -(define (-base x) (make-Base x #f)) +(define (-base x) (make-Base x #'dummy)) (define-syntax (te-tests stx) @@ -37,14 +37,12 @@ [(-mu x (Un N Sym x)) (-mu y (Un N Sym y))] ;; found bug [FAIL (Un (-mu heap-node - (-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))) #f #f #f values)) + (-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))))) (-base 'heap-empty)) (Un (-mu heap-node - (-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))) #f #f #f values)) + (-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))))) (-base 'heap-empty))])) - - (define-go type-equal-tests) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index ff06cc92..bfd1605f 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -12,7 +12,7 @@ (define Type/c (flat-named-contract - "Type" + 'Type (λ (e) (and (Type? e) (not (Scope? e)) @@ -129,7 +129,7 @@ (dt Result ([t Type/c] [f LFilterSet?] [o LatentObject?]) [#:frees (λ (frees) (combine-frees (map frees (list t f o))))] - [#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id f))]) + [#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id o))]) ;; types : Listof[Type] (dt Values ([rs (listof Result?)]) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 19f8a472..0f02eb63 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -19,7 +19,6 @@ (define -values make-Values) (define -pair make-Pair) -(define -struct make-Struct) (define -val make-Value) (define -Param make-Param) (define -box make-Box) @@ -211,6 +210,9 @@ (define (make-arr-dots dom rng dty dbound) (make-arr* dom rng #:drest (cons dty dbound))) +(define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values]) + (make-Struct name parent flds proc poly pred cert)) + (define make-pred-ty (case-lambda diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 53958415..515cbef6 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -1,4 +1,10 @@ #lang scheme/base + +#| +This file is for utilities that are only useful for Typed Scheme, but +don't depend on any other portion of the system +|# + (provide (all-defined-out)) (require "syntax-traversal.ss" (for-syntax scheme/base stxclass) scheme/match) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 01fa657d..28a80ce4 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -1,5 +1,10 @@ #lang scheme/base +#| +This file is for utilities that are of general interest, +at least theoretically. +|# + (require (for-syntax scheme/base stxclass) scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax mzlib/struct scheme/unit @@ -15,9 +20,7 @@ in-list-forever extend debug - in-syntax - ;; require macros - rep utils typecheck infer env private types) + in-syntax) (define-syntax (define-requirer stx) (syntax-parse stx