From f05fcfcf13ccb0e8f57edc86191fdaa6fef4da91 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 22:45:57 +0000 Subject: [PATCH] all of types/ now compiles everything that doesn't use Un out of convenience.ss added -out form for requires svn: r13931 --- collects/typed-scheme/private/env-lang.ss | 14 ++--- collects/typed-scheme/types/abbrev.ss | 7 +++ collects/typed-scheme/types/convenience.ss | 36 +---------- collects/typed-scheme/utils/tc-utils.ss | 24 ++++++- collects/typed-scheme/utils/utils.ss | 73 +++++++++++++--------- 5 files changed, 80 insertions(+), 74 deletions(-) diff --git a/collects/typed-scheme/private/env-lang.ss b/collects/typed-scheme/private/env-lang.ss index c047e3a61d..bbbfd3bd6e 100644 --- a/collects/typed-scheme/private/env-lang.ss +++ b/collects/typed-scheme/private/env-lang.ss @@ -2,15 +2,14 @@ (require (rename-in "../utils/utils.ss" [infer r:infer])) -(require (for-syntax (private type-effect-convenience) +(require (for-syntax (utils tc-utils) (env init-envs) scheme/base (r:infer infer) (only-in (r:infer infer-dummy) infer-param) - (except-in (rep effect-rep type-rep) make-arr) - "type-effect-convenience.ss" - (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - "union.ss")) + (except-in (rep object-rep filter-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr]))) (define-syntax (#%module-begin stx) (syntax-case stx (require) @@ -33,6 +32,5 @@ require (all-from-out scheme/base) (for-syntax - (all-from-out scheme/base - "type-effect-convenience.ss" - "union.ss"))) + (types convenience union) + (all-from-out scheme/base))) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 432f4e1db2..19f8a47232 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -218,3 +218,10 @@ (->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))] [(t) (make-pred-ty (list Univ) B t)])) + +(define (opt-fn args opt-args result) + (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))]) + (make-Function (list (make-arr* (append args (take opt-args i)) result)))))) + +(define-syntax-rule (->opt args ... [opt ...] res) + (opt-fn (list args ...) (list opt ...) res)) \ No newline at end of file diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss index b7078647cd..702a4c0cde 100644 --- a/collects/typed-scheme/types/convenience.ss +++ b/collects/typed-scheme/types/convenience.ss @@ -10,7 +10,7 @@ scheme/promise (for-syntax stxclass) (for-syntax scheme/base) - (for-template scheme/base scheme/contract scheme/tcp)) + (for-template scheme/base)) (provide (all-defined-out) (all-from-out "abbrev.ss") @@ -24,31 +24,6 @@ (apply Un (map tc-result-t args))) -(define-syntax (make-env stx) - (syntax-case stx () - [(_ e ...) - #`(list - #,@(map (lambda (e) - (syntax-case e () - [(nm ty) - (identifier? #'nm) - #`(list #'nm ty)] - [(e ty extra-mods ...) - #'(let ([x (list (let ([new-ns - (let* ([ns (make-empty-namespace)]) - (namespace-attach-module (current-namespace) - 'scheme/base - ns) - ns)]) - (parameterize ([current-namespace new-ns]) - (namespace-require 'scheme/base) - (namespace-require 'extra-mods) ... - e)) - ty)]) - ;(display x) (newline) - x)])) - (syntax->list #'(e ...))))])) - ;; if t is of the form (Pair t* (Pair t* ... (Listof t*))) ;; return t* ;; otherwise, return t @@ -67,14 +42,5 @@ [_ (exit t)])))) - -(define (opt-fn args opt-args result) - (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))]) - (make-Function (list (make-arr* (append args (take opt-args i)) result)))))) - -(define-syntax-rule (->opt args ... [opt ...] res) - (opt-fn (list args ...) (list opt ...) res)) - - ;; DO NOT USE if t contains #f (define (-opt t) (Un (-val #f) t)) \ No newline at end of file diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 75e5ac4740..53958415a1 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -1,6 +1,6 @@ #lang scheme/base (provide (all-defined-out)) -(require "syntax-traversal.ss" (for-syntax scheme/base) scheme/match) +(require "syntax-traversal.ss" (for-syntax scheme/base stxclass) scheme/match) ;; a parameter representing the original location of the syntax being currently checked (define current-orig-stx (make-parameter #'here)) @@ -142,4 +142,24 @@ (define (add-type-name-reference t) (type-name-references (cons t (type-name-references)))) - +;; environment constructor +(define-syntax (make-env stx) + (define-syntax-class spec + #:transparent + #:attributes (ty id) + (pattern [nm:identifier ty] + #:with id #'#'nm) + (pattern [e:expr ty extra-mods ...] + #:with id #'(let ([new-ns + (let* ([ns (make-empty-namespace)]) + (namespace-attach-module (current-namespace) + 'scheme/base + ns) + ns)]) + (parameterize ([current-namespace new-ns]) + (namespace-require 'scheme/base) + (namespace-require 'extra-mods) ... + e)))) + (syntax-parse stx + [(_ e:spec ...) + #'(list (list e.id e.ty) ...)])) \ No newline at end of file diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index a0bb5f1a1b..01fa657d8f 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -1,11 +1,8 @@ #lang scheme/base (require (for-syntax scheme/base stxclass) - scheme/contract - mzlib/plt-match - scheme/require-syntax - mzlib/struct - scheme/unit + scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax + mzlib/struct scheme/unit (except-in stxclass id)) (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log @@ -24,33 +21,51 @@ (define-syntax (define-requirer stx) (syntax-parse stx - [(_ nm:id) + [(_ nm:id nm-out:id) #`(... - (define-require-syntax (nm stx) - (syntax-parse stx - [(_ id:identifier ...) - (with-syntax ([(id* ...) - (map (lambda (id) - (datum->syntax - id - `(file - ,(path->string - (build-path (collection-path "typed-scheme" - #,(symbol->string (syntax-e #'nm))) - (string-append (symbol->string (syntax-e id)) - ".ss")))) - id id)) - (syntax->list #'(id ...)))]) - (syntax/loc stx (combine-in id* ...)))])))])) + (begin + (define-require-syntax (nm stx) + (syntax-parse stx + [(_ id:identifier ...) + (with-syntax ([(id* ...) + (map (lambda (id) + (datum->syntax + id + `(file + ,(path->string + (build-path (collection-path "typed-scheme" + #,(symbol->string (syntax-e #'nm))) + (string-append (symbol->string (syntax-e id)) + ".ss")))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-in id* ...)))])) + (define-provide-syntax (nm-out stx) + (syntax-parse stx + [(_ id:identifier ...) + (with-syntax ([(id* ...) + (map (lambda (id) + (datum->syntax + id + `(file + ,(path->string + (build-path (collection-path "typed-scheme" + #,(symbol->string (syntax-e #'nm))) + (string-append (symbol->string (syntax-e id)) + ".ss")))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-out (all-from-out id*) ...)))])) + (provide nm nm-out)))])) -(define-requirer rep) -(define-requirer infer) -(define-requirer typecheck) -(define-requirer utils) -(define-requirer env) -(define-requirer private) -(define-requirer types) +(define-requirer rep rep-out) +(define-requirer infer infer-out) +(define-requirer typecheck typecheck-out) +(define-requirer utils utils-out) +(define-requirer env env-out) +(define-requirer private private-out) +(define-requirer types types-out) (define-sequence-syntax in-syntax (lambda () #'syntax->list)