From 63748f9460a9f141c827dadebe0f43a1d7973e67 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 8 Sep 2010 15:30:33 -0400 Subject: [PATCH] Progress on delaying some environments. original commit: de0e8bc81ce566d9a540832f794d96b2cf9409ce --- collects/typed-scheme/main.rkt | 6 +- .../private/base-env-indexing.rkt | 11 +- collects/typed-scheme/private/base-env.rkt | 3 +- .../typed-scheme/private/base-special-env.rkt | 168 +++--------------- .../typed-scheme/private/base-structs.rkt | 99 +++++++++++ collects/typed-scheme/typed-scheme.rkt | 14 +- 6 files changed, 146 insertions(+), 155 deletions(-) create mode 100644 collects/typed-scheme/private/base-structs.rkt diff --git a/collects/typed-scheme/main.rkt b/collects/typed-scheme/main.rkt index eb46ac97..2082ac80 100644 --- a/collects/typed-scheme/main.rkt +++ b/collects/typed-scheme/main.rkt @@ -10,11 +10,7 @@ #%top-interaction lambda #%app)) -(require "private/base-env.rkt" - "private/base-special-env.rkt" - "private/base-env-numeric.rkt" - "private/base-env-indexing.rkt" - "private/extra-procs.rkt" +(require "private/extra-procs.rkt" (for-syntax "private/base-types-extra.rkt")) (provide (rename-out [with-handlers: with-handlers]) (for-syntax (all-from-out "private/base-types-extra.rkt")) diff --git a/collects/typed-scheme/private/base-env-indexing.rkt b/collects/typed-scheme/private/base-env-indexing.rkt index 23b72c05..04035590 100644 --- a/collects/typed-scheme/private/base-env-indexing.rkt +++ b/collects/typed-scheme/private/base-env-indexing.rkt @@ -1,11 +1,12 @@ -#lang scheme +#lang racket/base (require (rename-in "../utils/utils.rkt" [infer r:infer]) - (for-syntax (types abbrev) (env init-envs) (r:infer infer-dummy infer) - "base-env-indexing-abs.rkt")) + (types abbrev) (env init-envs) (r:infer infer-dummy infer) + "base-env-indexing-abs.rkt") -(define-for-syntax e (parameterize ([infer-param infer]) (indexing -Integer))) -(begin-for-syntax (initialize-type-env e)) +(define e (parameterize ([infer-param infer]) (indexing -Integer))) +(define (initialize-indexing) (initialize-type-env e)) +(provide initialize-indexing) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index dfa13622..c4347f7c 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -11,8 +11,7 @@ "extra-procs.rkt" (only-in '#%kernel [apply kernel:apply]) (only-in racket/private/pre-base new-apply-proc) - (for-syntax (only-in racket/private/pre-base new-apply-proc) - #;racket/string) + (for-syntax (only-in racket/private/pre-base new-apply-proc)) scheme/promise scheme/system racket/mpair (only-in string-constants/private/only-once maybe-print-message) diff --git a/collects/typed-scheme/private/base-special-env.rkt b/collects/typed-scheme/private/base-special-env.rkt index 02c33f62..95d47db7 100644 --- a/collects/typed-scheme/private/base-special-env.rkt +++ b/collects/typed-scheme/private/base-special-env.rkt @@ -1,16 +1,10 @@ #lang racket/base -;; these are libraries providing functions we add types to that are not in scheme/base +;; this file cheats to define types for unexported variables that are expanded into by Racket macros (require - "extra-procs.rkt" "../utils/utils.rkt" - (only-in scheme/list cons? take drop add-between last filter-map) - (only-in rnrs/lists-6 fold-left) - '#%paramz - (only-in racket/match/runtime match:error) - scheme/promise - string-constants/string-constant - ;(prefix-in ce: test-engine/scheme-tests) + racket/promise + string-constants/string-constant (for-syntax scheme/base syntax/parse (only-in unstable/syntax syntax-local-eval) @@ -18,137 +12,42 @@ (env init-envs) (except-in (rep filter-rep object-rep type-rep) make-arr) (types convenience union) - (only-in (types convenience) [make-arr* make-arr]) - (typecheck tc-structs)) - (for-meta 2 scheme/base syntax/parse)) - - -(define-for-syntax (initialize-others) - - (define-syntax define-hierarchy - (syntax-rules (define-hierarchy) - [(_ parent ([name : type] ...) - (define-hierarchy child (spec ...) grand ...) - ...) - (begin - (d-s parent ([name : type] ...)) - (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...) - ...)])) - - (define-syntax define-sub-hierarchy - (syntax-rules (define-hierarchy) - [(_ [child parent] (inheritance ...) ([name : type] ...) - (define-hierarchy grandchild (spec ...) great ...) - ...) - (begin - (d-s [child parent] ([name : type] ...) (inheritance ...)) - (define-sub-hierarchy [grandchild child] - (inheritance ... type ...) (spec ...) - great - ...) - ...)])) - - (define-hierarchy srcloc - ([source : Univ] - [line : (*Un -Integer (-val #f))] - [column : (*Un -Integer (-val #f))] - [position : (*Un -Integer (-val #f))] - [span : (*Un -Integer (-val #f))])) - - (define-hierarchy date - ([second : -Number] - [minute : -Number] - [hour : -Number] - [day : -Number] - [month : -Number] - [year : -Number] - [weekday : -Number] - [year-day : -Number] - [dst? : -Boolean] - [time-zone-offset : -Number])) - - (define-hierarchy arity-at-least - ([value : -Nat])) - - (define-hierarchy exn - ([message : -String] [continuation-marks : -Cont-Mark-Set]) - - (define-hierarchy exn:break ([continuation : top-func])) - - (define-hierarchy exn:fail () - - (define-hierarchy exn:fail:contract () - (define-hierarchy exn:fail:contract:arity ()) - (define-hierarchy exn:fail:contract:divide-by-zero ()) - (define-hierarchy exn:fail:contract:non-fixnum-result ()) - (define-hierarchy exn:fail:contract:continuation ()) - (define-hierarchy exn:fail:contract:variable ())) - - (define-hierarchy exn:fail:syntax ([exprs : (-lst (-Syntax Univ))])) - - (define-hierarchy exn:fail:read - ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc - (define-hierarchy exn:fail:read:eof ()) - (define-hierarchy exn:fail:read:non-char ())) - - (define-hierarchy exn:fail:filesystem () - (define-hierarchy exn:fail:filesystem:exists ()) - (define-hierarchy exn:fail:filesystem:version ())) - - (define-hierarchy exn:fail:network ()) - - (define-hierarchy exn:fail:out-of-memory ()) - - (define-hierarchy exn:fail:unsupported ()) - - (define-hierarchy exn:fail:user ()))) - - ;; cce: adding exn:break would require a generic type for continuations - - ) - -(provide (for-syntax initial-env/special-case initialize-others initialize-type-env) - define-initial-env) + (only-in (types convenience) [make-arr* make-arr]))) (define-syntax (define-initial-env stx) - (syntax-case stx () - [(_ initial-env make-promise-ty language-ty qq-append-ty - [id-expr ty] ...) - (with-syntax ([(_ make-promise . _) - (local-expand #'(delay 3) - 'expression - null)] - [language - (local-expand #'(this-language) - 'expression - null)] - [(_ qq-append . _) - (local-expand #'`(,@'() 1) - 'expression - null)] - [(id ...) - (for/list ([expr (syntax->list #'(id-expr ...))]) - (syntax-local-eval expr))]) - #`(define-for-syntax initial-env + (syntax-parse stx + [(_ initialize-env [id-expr ty] ...) + (with-syntax ([(id ...) + (for/list ([expr (syntax->list #'(id-expr ...))]) + (syntax-local-eval expr))]) + #`(begin + (define-for-syntax initial-env (make-env - [make-promise make-promise-ty] - [language language-ty] - [qq-append qq-append-ty] - [id ty] ...)))])) + [id ty] ...)) + (define-for-syntax (initialize-env) + (initialize-type-env initial-env)) + (provide (for-syntax initialize-env))))])) - - -(define-initial-env initial-env/special-case +(define-initial-env initialize-special ;; make-promise - (-poly (a) (-> (-> a) (-Promise a))) + [(syntax-parse (local-expand #'(delay 3) 'expression null) + #:context #'make-promise + [(_ mp . _) #'mp]) + (-poly (a) (-> (-> a) (-Promise a)))] ;; language - -Symbol + [(syntax-parse (local-expand #'(this-language) 'expression null) + #:context #'language + [lang #'lang]) + -Symbol] ;; qq-append - (-poly (a b) + [(syntax-parse (local-expand #'`(,@'() 1) 'expression null) + #:context #'qq-append + [(_ qqa . _) #'qqa]) + (-poly (a b) (cl->* (-> (-lst a) (-val '()) (-lst a)) - (-> (-lst a) (-lst b) (-lst (*Un a b))))) + (-> (-lst a) (-lst b) (-lst (*Un a b)))))] ;; make-sequence [(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) #:context #'make-sequence @@ -234,12 +133,3 @@ #'i-n]) (->opt [-Input-Port -Symbol] (-seq -Bytes))]) - - - -(begin-for-syntax - (initialize-type-env initial-env/special-case) - (initialize-others)) - - - diff --git a/collects/typed-scheme/private/base-structs.rkt b/collects/typed-scheme/private/base-structs.rkt new file mode 100644 index 00000000..03bcb0f3 --- /dev/null +++ b/collects/typed-scheme/private/base-structs.rkt @@ -0,0 +1,99 @@ +#lang racket/base + +(require + "../utils/utils.rkt" + (utils tc-utils) + (env init-envs) + (except-in (rep filter-rep object-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr]) + (typecheck tc-structs)) + +(require (for-template racket/base)) + +(provide initialize-structs) + +(define-syntax define-hierarchy + (syntax-rules (define-hierarchy) + [(_ parent ([name : type] ...) + (define-hierarchy child (spec ...) grand ...) + ...) + (begin + (d-s parent ([name : type] ...)) + (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...) + ...)])) + +(define-syntax define-sub-hierarchy + (syntax-rules (define-hierarchy) + [(_ [child parent] (inheritance ...) ([name : type] ...) + (define-hierarchy grandchild (spec ...) great ...) + ...) + (begin + (d-s [child parent] ([name : type] ...) (inheritance ...)) + (define-sub-hierarchy [grandchild child] + (inheritance ... type ...) (spec ...) + great + ...) + ...)])) + + +(define (initialize-structs) + + + (define-hierarchy srcloc + ([source : Univ] + [line : (*Un -Integer (-val #f))] + [column : (*Un -Integer (-val #f))] + [position : (*Un -Integer (-val #f))] + [span : (*Un -Integer (-val #f))])) + + (define-hierarchy date + ([second : -Number] + [minute : -Number] + [hour : -Number] + [day : -Number] + [month : -Number] + [year : -Number] + [weekday : -Number] + [year-day : -Number] + [dst? : -Boolean] + [time-zone-offset : -Number])) + + (define-hierarchy arity-at-least + ([value : -Nat])) + + (define-hierarchy exn + ([message : -String] [continuation-marks : -Cont-Mark-Set]) + + (define-hierarchy exn:break ([continuation : top-func])) + + (define-hierarchy exn:fail () + + (define-hierarchy exn:fail:contract () + (define-hierarchy exn:fail:contract:arity ()) + (define-hierarchy exn:fail:contract:divide-by-zero ()) + (define-hierarchy exn:fail:contract:non-fixnum-result ()) + (define-hierarchy exn:fail:contract:continuation ()) + (define-hierarchy exn:fail:contract:variable ())) + + (define-hierarchy exn:fail:syntax ([exprs : (-lst (-Syntax Univ))])) + + (define-hierarchy exn:fail:read + ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc + (define-hierarchy exn:fail:read:eof ()) + (define-hierarchy exn:fail:read:non-char ())) + + (define-hierarchy exn:fail:filesystem () + (define-hierarchy exn:fail:filesystem:exists ()) + (define-hierarchy exn:fail:filesystem:version ())) + + (define-hierarchy exn:fail:network ()) + + (define-hierarchy exn:fail:out-of-memory ()) + + (define-hierarchy exn:fail:unsupported ()) + + (define-hierarchy exn:fail:user ()))) + + ;; cce: adding exn:break would require a generic type for continuations + ) \ No newline at end of file diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 88f1e416..5ef1eef9 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -1,6 +1,11 @@ #lang racket/base -(require (for-syntax racket/base "typecheck/renamer.rkt")) +(require (for-syntax racket/base "typecheck/renamer.rkt") + "private/base-special-env.rkt" + "private/base-env.rkt" + "private/base-env-numeric.rkt") + +(begin-for-syntax (initialize-special)) (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] @@ -10,15 +15,16 @@ with-type) (define-syntax (module-begin stx) - (dynamic-require 'typed-scheme/private/base-env #f) - (dynamic-require 'typed-scheme/private/base-env-numeric #f) - (dynamic-require 'typed-scheme/private/base-env-indexing #f) + ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs)) + ((dynamic-require 'typed-scheme/private/base-env-indexing 'initialize-indexing)) ((dynamic-require 'typed-scheme/core 'mb-core) stx)) (define-syntax (top-interaction stx) + ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs)) ((dynamic-require 'typed-scheme/core 'ti-core) stx)) (define-syntax (with-type stx) + ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs)) ((dynamic-require 'typed-scheme/core 'wt-core) stx))