From f23af68d6b0bbc9a82f8fea2178e5e7dfaf2d459 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 12 Apr 2008 00:10:32 +0000 Subject: [PATCH] Split type defns into base-types.ss Reformat. svn: r9273 --- collects/typed-scheme/private/base-env.ss | 74 ------------ collects/typed-scheme/private/base-types.ss | 112 +++++++++++++++++++ collects/typed-scheme/private/prims.ss | 2 +- collects/typed-scheme/private/type-env.ss | 2 + collects/typed-scheme/private/typechecker.ss | 6 +- collects/typed-scheme/typed-scheme.ss | 1 + 6 files changed, 118 insertions(+), 79 deletions(-) create mode 100644 collects/typed-scheme/private/base-types.ss diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index b777ed1ee1..0076bd5f99 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -492,79 +492,5 @@ (begin-for-syntax (initialize-type-env initial-env) (initialize-others)) -;; the initial type name environment - just the base types -(define-syntax (define-tname-env stx) - (syntax-case stx () - [(_ var provider [nm ty] ...) - #`(begin - (define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ... - (provide nm) ... - (define-syntax provider (lambda (stx) #'(begin (provide nm) ...))) - (provide provider) - (begin-for-syntax - (initialize-type-name-env - (list (list #'nm ty) ...))))])) -(define-syntax (define-other-types stx) - (syntax-case stx () - [(_ provider requirer nm ...) - (with-syntax ([(nms ...) (generate-temporaries #'(nm ...))]) - (let ([body-maker (lambda (stx) - (map (lambda (nm nms) (datum->syntax stx `(rename ,#'mod ,nm ,nms))) - (syntax->list #'(nm ...)) - (syntax->list #'(nms ...))))]) - #'(begin (define-syntax nms (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ... - (provide nms) ... - (define-syntax (requirer stx) - (syntax-case stx () - [(_ mod) - (datum->syntax - stx - `(require . ,(map (lambda (nm* nms*) (datum->syntax stx `(rename ,#'mod ,nm* ,nms*))) - (list 'nm ...) - (list #'nms ...))))])) - (define-syntax provider (lambda (stx) #'(begin (provide (rename-out [nms nm])) ...))) - (provide provider requirer))))])) - -;; the initial set of available type names -(define-tname-env initial-type-names provide-tnames - [Number N] - [Integer -Integer] - [Void -Void] - [Boolean B] - [Symbol Sym] - [String -String] - [Any Univ] - [Port -Port] - [Path -Path] - [Regexp -Regexp] - [PRegexp -PRegexp] - [Char -Char] - [Option (-poly (a) (-opt a))] - [List (-lst Univ)] - [Listof -Listof] - [Namespace -Namespace] - [Input-Port -Input-Port] - [Output-Port -Output-Port] - [Bytes -Bytes] - [EOF (-val eof)] - [Keyword -Keyword] - [HashTable (-poly (a b) (-HT a b))] - [Promise (-poly (a) (-Promise a))] - [Pair (-poly (a b) (-pair a b))] - [Box (-poly (a) (make-Box a))] - [Syntax Any-Syntax] - [Identifier Ident] - ) - -(define-other-types - provide-extra-tnames - require-extra-tnames - - - -> U mu Un All Opaque Vectorof - Parameter Tuple Class - ) - -(provide-extra-tnames) diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss new file mode 100644 index 0000000000..807f5e2da8 --- /dev/null +++ b/collects/typed-scheme/private/base-types.ss @@ -0,0 +1,112 @@ +#lang scheme/base + +(require (for-template (only-in (lib "list.ss") foldl) + scheme/base + '#%paramz + scheme/promise + string-constants/string-constant + #;'#%more-scheme + #;'#%qq-and-or + (only-in scheme/match/patterns match:error)) + ) + + +(require + "extra-procs.ss" + scheme/promise + (except-in "type-rep.ss" make-arr) + (only-in scheme/list cons?) + "type-effect-convenience.ss" + (only-in "type-effect-convenience.ss" [make-arr* make-arr]) + "union.ss" + string-constants/string-constant + (only-in scheme/match/patterns match:error) + "tc-structs.ss") + +(require (for-syntax + scheme/base + "init-envs.ss" + (except-in "type-rep.ss" make-arr) + (only-in (lib "list.ss") foldl) + "type-effect-convenience.ss" + (only-in "type-effect-convenience.ss" [make-arr* make-arr]) + "union.ss" + string-constants/string-constant + (only-in scheme/match/patterns match:error) + "tc-structs.ss")) + +;; the initial type name environment - just the base types +(define-syntax (define-tname-env stx) + (syntax-case stx () + [(_ var provider [nm ty] ...) + #`(begin + (define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ... + (provide nm) ... + (define-syntax provider (lambda (stx) #'(begin (provide nm) ...))) + (provide provider) + (begin-for-syntax + (initialize-type-name-env + (list (list #'nm ty) ...))))])) + +(define-syntax (define-other-types stx) + (syntax-case stx () + [(_ provider requirer nm ...) + (with-syntax ([(nms ...) (generate-temporaries #'(nm ...))]) + (let ([body-maker (lambda (stx) + (map (lambda (nm nms) (datum->syntax stx `(rename ,#'mod ,nm ,nms))) + (syntax->list #'(nm ...)) + (syntax->list #'(nms ...))))]) + #'(begin (define-syntax nms (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ... + (provide nms) ... + (define-syntax (requirer stx) + (syntax-case stx () + [(_ mod) + (datum->syntax + stx + `(require . ,(map (lambda (nm* nms*) (datum->syntax stx `(rename ,#'mod ,nm* ,nms*))) + (list 'nm ...) + (list #'nms ...))))])) + (define-syntax provider (lambda (stx) #'(begin (provide (rename-out [nms nm])) ...))) + (provide provider requirer))))])) + +;; the initial set of available type names +(define-tname-env initial-type-names provide-tnames + [Number N] + [Integer -Integer] + [Void -Void] + [Boolean B] + [Symbol Sym] + [String -String] + [Any Univ] + [Port -Port] + [Path -Path] + [Regexp -Regexp] + [PRegexp -PRegexp] + [Char -Char] + [Option (-poly (a) (-opt a))] + [List (-lst Univ)] + [Listof -Listof] + [Namespace -Namespace] + [Input-Port -Input-Port] + [Output-Port -Output-Port] + [Bytes -Bytes] + [EOF (-val eof)] + [Keyword -Keyword] + [HashTable (-poly (a b) (-HT a b))] + [Promise (-poly (a) (-Promise a))] + [Pair (-poly (a b) (-pair a b))] + [Box (-poly (a) (make-Box a))] + [Syntax Any-Syntax] + [Identifier Ident] + ) + +(define-other-types + provide-extra-tnames + require-extra-tnames + + + -> U mu Un All Opaque Vectorof + Parameter Tuple Class + ) + +(provide-extra-tnames) \ No newline at end of file diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 45452b4f0b..57d8db02df 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -40,7 +40,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (except-in (lib "contract.ss") ->) (only-in (lib "contract.ss") [-> c->]) (lib "struct.ss") - "base-env.ss") + "base-types.ss") diff --git a/collects/typed-scheme/private/type-env.ss b/collects/typed-scheme/private/type-env.ss index c42d110d04..7467776502 100644 --- a/collects/typed-scheme/private/type-env.ss +++ b/collects/typed-scheme/private/type-env.ss @@ -20,11 +20,13 @@ ;; add a single type to the mapping ;; identifier type -> void (define (register-type id type) + ;(printf "register-type ~a~n" (syntax-e id)) (module-identifier-mapping-put! the-mapping id type)) ;; add a single type to the mapping ;; identifier type -> void (define (register-type/undefined id type) + ;(printf "register-type/undef ~a~n" (syntax-e id)) (module-identifier-mapping-put! the-mapping id (box type))) ;; add a bunch of types to the mapping diff --git a/collects/typed-scheme/private/typechecker.ss b/collects/typed-scheme/private/typechecker.ss index 5b48745b83..0656c6e0d6 100644 --- a/collects/typed-scheme/private/typechecker.ss +++ b/collects/typed-scheme/private/typechecker.ss @@ -3,7 +3,7 @@ (require "unit-utils.ss" mzlib/trace (only-in mzlib/unit provide-signature-elements) - "signatures.ss" #;"typechecker-unit.ss" "tc-toplevel.ss" + "signatures.ss" "tc-toplevel.ss" "tc-if-unit.ss" "tc-lambda-unit.ss" "tc-app-unit.ss" "tc-let-unit.ss" "tc-expr-unit.ss" "check-subforms-unit.ss") @@ -11,6 +11,4 @@ (provide-signature-elements typechecker^) (define-values/link-units/infer - ;typechecker@ - tc-toplevel@ - tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@) + tc-toplevel@ tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index baac75e0dc..80ed340dc4 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -5,6 +5,7 @@ "private/extra-procs.ss" "private/internal-forms.ss" "private/base-env.ss" + "private/base-types.ss" (for-syntax scheme/base "private/type-utils.ss"