From aa2a031828c6e35187ece96c265e3d844330933b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 2 Sep 2008 20:25:23 -0400 Subject: [PATCH 1/8] progress original commit: 85a0fa22d10e17df8a9d0dc1dcff56c2cc9a43a2 --- collects/typed-scheme/private/base-env.ss | 2 + .../private/check-subforms-unit.ss | 2 +- collects/typed-scheme/private/extra-procs.ss | 7 +- collects/typed-scheme/private/infer-unit.ss | 6 +- collects/typed-scheme/private/tc-app-unit.ss | 73 ++++++++++++++----- collects/typed-scheme/private/tc-expr-unit.ss | 2 +- collects/typed-scheme/private/tc-utils.ss | 2 +- .../private/type-effect-convenience.ss | 3 +- collects/typed-scheme/typed-scheme.ss | 2 +- 9 files changed, 72 insertions(+), 27 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 59708588..7f1ba924 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -555,6 +555,8 @@ [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] + + [foo (make-Function (list (make-arr (list N) B #f #f (list (cons '#:bar B)) null null)))] ) (begin-for-syntax diff --git a/collects/typed-scheme/private/check-subforms-unit.ss b/collects/typed-scheme/private/check-subforms-unit.ss index 1658e455..554bbea1 100644 --- a/collects/typed-scheme/private/check-subforms-unit.ss +++ b/collects/typed-scheme/private/check-subforms-unit.ss @@ -21,7 +21,7 @@ (define body-ty #f) (define (get-result-ty t) (match t - [(Function: (list (arr: _ rngs #f _ _ _) ...)) (apply Un rngs)] + [(Function: (list (arr: _ rngs #f _ '() _ _) ...)) (apply Un rngs)] [_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)])) (let loop ([form form]) (parameterize ([current-orig-stx form]) diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss index 83aa9c40..b5cd5378 100644 --- a/collects/typed-scheme/private/extra-procs.ss +++ b/collects/typed-scheme/private/extra-procs.ss @@ -1,5 +1,5 @@ #lang scheme/base -(provide assert call-with-values* values*) +(provide assert call-with-values* values* foo) (define (assert v) (unless v @@ -15,4 +15,7 @@ (car as) (map car bss)))) (define call-with-values* call-with-values) -(define values* values) \ No newline at end of file +(define values* values) + +(define (foo x #:bar [bar #f]) + bar) \ No newline at end of file diff --git a/collects/typed-scheme/private/infer-unit.ss b/collects/typed-scheme/private/infer-unit.ss index d04d5b36..b9590895 100644 --- a/collects/typed-scheme/private/infer-unit.ss +++ b/collects/typed-scheme/private/infer-unit.ss @@ -146,7 +146,7 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f t-thn-eff t-els-eff) s-arr)]) + [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null t-thn-eff t-els-eff) s-arr)]) (move-vars-to-dmap new-cset dbound vars))] [((arr: ts t #f #f '() t-thn-eff t-els-eff) (arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff)) @@ -159,7 +159,7 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f s-thn-eff s-els-eff))]) + [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null s-thn-eff s-els-eff))]) (move-vars-to-dmap new-cset dbound vars))] [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) @@ -205,7 +205,7 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] [new-cset (cgen/arr V (append vars X) t-arr - (make-arr (append ss new-tys) s #f (cons s-dty dbound) s-thn-eff s-els-eff))]) + (make-arr (append ss new-tys) s #f (cons s-dty dbound) null s-thn-eff s-els-eff))]) (move-vars+rest-to-dmap new-cset dbound vars)))] ;; If dotted <: starred is correct, add it below. Not sure it is. [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index b1758d54..06b372ab 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -159,7 +159,7 @@ (define-values (fixed-args tail) (split (syntax->list args))) (match f-ty - [(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...))) + [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...))) (when (null? doms) (tc-error/expr #:return (ret (Un)) "empty case-lambda given as argument to apply")) @@ -204,7 +204,7 @@ (printf/log "Non-poly apply, ... arg\n") (ret (car rngs*))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) + [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) @@ -214,7 +214,7 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) + [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -259,14 +259,14 @@ (tc-error/expr #:return (ret (Un)) "Function has no cases")] [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) + (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) + [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -378,8 +378,8 @@ (define (poly-fail t argtypes #:name [name #f]) (match t - [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))) - (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...)))) + [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) + (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) (let ([fcn-string (if name (format "function ~a (over ~~a)" (syntax->datum name)) "function over ~a")]) @@ -429,7 +429,8 @@ "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtypes))])] ;; single clause functions - [(tc-result: (and t (Function: (list (arr: dom rng rest #f latent-thn-effs latent-els-effs)))) + ;; FIXME - error on non-optional keywords + [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs)))) thn-eff els-eff) (let-values ([(thn-eff els-eff) (tc-args argtypes arg-thn-effs arg-els-effs dom rest @@ -437,7 +438,7 @@ (syntax->list args))]) (ret rng thn-eff els-eff))] ;; non-polymorphic case-lambda functions - [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) latent-thn-effs latent-els-effs) ..1))) + [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1))) thn-eff els-eff) (let loop ([doms* doms] [rngs rngs] [rests* rests]) (cond [(null? doms*) @@ -453,19 +454,19 @@ ;; simple polymorphic functions, no rest arguments [(tc-result: (and t (or (Poly: vars - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...))) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))) (PolyDots: (list vars ... _) - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...)))))) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))))) (handle-clauses (doms rngs) f-stx (lambda (dom _) (= (length dom) (length argtypes))) (lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected)) t argtypes expected)] ;; polymorphic varargs [(tc-result: (and t - (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...))) + (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))) ;; we want to infer the dotted-var here as well, and we don't use these separately ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var) - (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...)))))) + (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))))) (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx)) (handle-clauses (doms rests rngs) f-stx (lambda (dom rest rng) (<= (length dom) (length argtypes))) @@ -474,7 +475,7 @@ ;; polymorphic ... type [(tc-result: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) thn-effs els-effs) ...))))) + (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...))))) (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx)) (handle-clauses (doms dtys dbounds rngs) f-stx (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes)) @@ -566,6 +567,32 @@ [(tc-result: t) (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) +(define (tc-keywords form arities kws kw-args pos-args expected) + (match arities + [(list (arr: dom rng rest #f (list (and ktys (cons formal-kws formal-kw-tys)) ...) _ _)) + (for ([k kws] + [ty (map tc-expr/t (syntax->list kw-args))]) + (cond [(assq k ktys) + => + (match-lambda [(cons k kty) + (unless (subtype ty kty) + (tc-error/delayed + #:stx form + "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" + kty ty k))])] + [else + (tc-error/expr #:return (ret (Un)) + "function does not accept keyword argument ~a" k)])) + (tc/funapp #'form #'form (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] + [_ (int-err "case-lambda w/ keywords not supported")])) + + +(define (type->list t) + (match t + [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] + [(Value: '()) null] + [_ (int-err "bad value in type->list: ~a" t)])) + (define (tc/app/internal form expected) (kernel-syntax-case* form #f (values apply not list list* call-with-values do-make-object make-object cons @@ -585,7 +612,7 @@ [(Values: ts) ts] [_ (list t)])) (match prod-t - [(Function: (list (arr: (list) vals _ #f _ _))) + [(Function: (list (arr: (list) vals _ #f '() _ _))) (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)] [_ (tc-error/expr #:return (ret (Un)) "First argument to call with values must be a function that can accept no arguments, got: ~a" @@ -621,11 +648,23 @@ [(tc-result: t thn-eff els-eff) (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])] ;; special case for `apply' - [(#%plain-app apply f . args) (tc/apply #'f #'args)] + [(#%plain-app apply f . args) (tc/apply #'f #'args)] + ;; special case for keywords + [(#%plain-app + (#%plain-app kpe kws num fn) + kw-list + (#%plain-app list . kw-arg-list) + . pos-args) + (eq? (syntax-e #'kpe) 'keyword-procedure-extract) + (match (tc-expr #'fn) + [(tc-result: (Function: arities)) + (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] + [t (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) - (let-loop-check #'form #'lp #'actuals #'args #'body expected)] + (let-loop-check form #'lp #'actuals #'args #'body expected)] ;; or/andmap of ... argument [(#%plain-app or/andmap f arg) (and diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/private/tc-expr-unit.ss index feb7129a..163fa343 100644 --- a/collects/typed-scheme/private/tc-expr-unit.ss +++ b/collects/typed-scheme/private/tc-expr-unit.ss @@ -41,7 +41,7 @@ [(null? v) (-val null)] [(symbol? v) (-val v)] [(string? v) -String] - [(keyword? v) -Keyword] + [(keyword? v) (-val v)] [(bytes? v) -Bytes] [(list? v) (-Tuple (map tc-literal v))] [(vector? v) (make-Vector (types-of-literals (vector->list v)))] diff --git a/collects/typed-scheme/private/tc-utils.ss b/collects/typed-scheme/private/tc-utils.ss index 69709e3e..3e44382e 100644 --- a/collects/typed-scheme/private/tc-utils.ss +++ b/collects/typed-scheme/private/tc-utils.ss @@ -70,7 +70,7 @@ (unless (null? stxs) (raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) (apply append stxs))))])) -(define delay-errors? (make-parameter #t)) +(define delay-errors? (make-parameter #f)) (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest) (let ([stx (locate-stx stx*)]) diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index dbbf0ec3..a4771751 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -82,7 +82,8 @@ (case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))] [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] - [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)])) + [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)] + [(dom rng rest drest kws eff1 eff2) (make-arr dom rng rest drest kws eff1 eff2)])) (define (make-arr-dots dom rng dty dbound) (make-arr* dom rng #f (cons dty dbound) null null)) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 19c9c9cb..2eb33e21 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -31,7 +31,7 @@ (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] [#%plain-lambda lambda] - [#%plain-app #%app] + [#%app #%app] [require require])) (define-for-syntax catch-errors? #f) From f4eec91021e7ba0df5b8df8cef87a6bd361d5151 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 4 Sep 2008 17:02:33 -0400 Subject: [PATCH 2/8] New representation that accomodates mandatory and optional keyword args. original commit: 79e3a0c4c68070d6a558a006d70c326f4ee2d28a --- collects/typed-scheme/private/base-env.ss | 2 +- collects/typed-scheme/private/tc-app-unit.ss | 9 +++++---- collects/typed-scheme/private/type-rep.ss | 16 ++++++++++++---- 3 files changed, 18 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 7f1ba924..4c728c58 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -556,7 +556,7 @@ [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] - [foo (make-Function (list (make-arr (list N) B #f #f (list (cons '#:bar B)) null null)))] + [foo (make-Function (list (make-arr (list N) B #f #f (list (make-Keyword '#:bar B #f)) null null)))] ) (begin-for-syntax diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index 06b372ab..ac5347ef 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -569,12 +569,13 @@ (define (tc-keywords form arities kws kw-args pos-args expected) (match arities - [(list (arr: dom rng rest #f (list (and ktys (cons formal-kws formal-kw-tys)) ...) _ _)) + [(list (arr: dom rng rest #f (list (and ktys (Keyword: formal-kws formal-kw-tys (and #f required?))) ...) _ _)) (for ([k kws] [ty (map tc-expr/t (syntax->list kw-args))]) - (cond [(assq k ktys) + (cond [(for/or ([e ktys]) + (and (eq? (Keyword-kw e) k) e)) => - (match-lambda [(cons k kty) + (match-lambda [(Keyword: k kty req?) (unless (subtype ty kty) (tc-error/delayed #:stx form @@ -583,7 +584,7 @@ [else (tc-error/expr #:return (ret (Un)) "function does not accept keyword argument ~a" k)])) - (tc/funapp #'form #'form (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] + (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] [_ (int-err "case-lambda w/ keywords not supported")])) diff --git a/collects/typed-scheme/private/type-rep.ss b/collects/typed-scheme/private/type-rep.ss index df51d4c8..c63a2a8f 100644 --- a/collects/typed-scheme/private/type-rep.ss +++ b/collects/typed-scheme/private/type-rep.ss @@ -90,18 +90,26 @@ pred-id cert)]) +;; kw : keyword? +;; ty : Type +;; required? : Boolean +(dt Keyword (kw ty required?) + [#:frees (free-vars* ty) + (free-idxs* ty)] + [#:fold-rhs (*Keyword kw (type-rec-id ty))]) + ;; dom : Listof[Type] ;; rng : Type ;; rest : Option[Type] ;; drest : Option[Cons[Type,Name or nat]] -;; kws : Listof[Cons[Kw, Type]] +;; kws : Listof[Keyword] ;; rest and drest NOT both true ;; thn-eff : Effect ;; els-eff : Effect ;; arr is NOT a Type (dt arr (dom rng rest drest kws thn-eff els-eff) [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) - (map cdr kws) + (map Keyword-ty kws) dom))) (match drest [(cons t (? symbol? bnd)) @@ -112,7 +120,7 @@ (map make-invariant (map free-vars* (append thn-eff els-eff))))) (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null) - (map cdr kws) + (map Keyword-ty kws) dom))) (match drest [(cons t (? number? bnd)) @@ -127,7 +135,7 @@ (and rest (type-rec-id rest)) (and drest (cons (type-rec-id (car drest)) (cdr drest))) (for/list ([kw kws]) - (cons (car kw) (type-rec-id (cdr kw)))) + (cons (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw))) (map effect-rec-id thn-eff) (map effect-rec-id els-eff))]) From 9a357ebf846c053772315437e3077ca59b7ffda7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 4 Sep 2008 17:59:36 -0400 Subject: [PATCH 3/8] Fixed printing for new rep. Handle mandatory and optional keyword args. original commit: 801156229a9a8498f9860aed405b3a61ed252d03 --- collects/typed-scheme/private/tc-app-unit.ss | 44 ++++++++++++------- .../private/type-effect-printer.ss | 6 ++- 2 files changed, 34 insertions(+), 16 deletions(-) diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index ac5347ef..5d8afe8a 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -569,21 +569,35 @@ (define (tc-keywords form arities kws kw-args pos-args expected) (match arities - [(list (arr: dom rng rest #f (list (and ktys (Keyword: formal-kws formal-kw-tys (and #f required?))) ...) _ _)) - (for ([k kws] - [ty (map tc-expr/t (syntax->list kw-args))]) - (cond [(for/or ([e ktys]) - (and (eq? (Keyword-kw e) k) e)) - => - (match-lambda [(Keyword: k kty req?) - (unless (subtype ty kty) - (tc-error/delayed - #:stx form - "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" - kty ty k))])] - [else - (tc-error/expr #:return (ret (Un)) - "function does not accept keyword argument ~a" k)])) + [(list (arr: dom rng rest #f ktys _ _)) + ;; assumes that everything is in sorted order + (let loop ([actual-kws kws] + [actuals (map tc-expr/t (syntax->list kw-args))] + [formals ktys]) + (match* (actual-kws formals) + [('() '()) + (void)] + [(_ '()) + (tc-error/expr #:return (ret (Un)) + "Unexpected keyword argument ~a" (car actual-kws))] + [('() (cons fst rst)) + (match fst + [(Keyword: k _ #t) + (tc-error/expr #:return (ret (Un)) + "Missing keyword argument ~a" k)] + [_ (loop actual-kws actuals rst)])] + [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) + (cond [(eq? k k*) ;; we have a match + (unless (subtype (car actuals) t) + (tc-error/delayed + "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" + t (car actuals) k)) + (loop kws-rest (cdr actuals) form-rest)] + [req? ;; this keyword argument was required + (tc-error/delayed "Missing keyword argument ~a" k*) + (loop kws-rest (cdr actuals) form-rest)] + [else ;; otherwise, ignore this formal param, and continue + (loop actual-kws actuals form-rest)])])) (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] [_ (int-err "case-lambda w/ keywords not supported")])) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index 513f61bd..72038bb8 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -50,7 +50,11 @@ (fp "(") (for-each (lambda (t) (fp "~a " t)) dom) (for ([kw kws]) - (fp "~a ~a " (car kw) (cdr kw))) + (match kw + [(Keyword: k t req?) + (if req? + (fp "~a ~a " k t) + (fp "[~a ~a] " k t))])) (when rest (fp "~a* " rest)) (when drest From 8701782f178b9f65c8e6f2aab1a87a7263e6bb7c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 5 Sep 2008 16:52:00 -0400 Subject: [PATCH 4/8] more stuff works original commit: a1825082df673c1fd4bf8e288230c63bb142d9f3 --- collects/typed-scheme/private/base-env.ss | 26 +++++++++++-------- .../private/type-effect-convenience.ss | 19 ++++++++++++-- 2 files changed, 32 insertions(+), 13 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 4c728c58..5703eb4f 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -57,6 +57,9 @@ [qq-append qq-append-ty] [id ty] ...)))])) +(define-for-syntax (one-of/c . args) + (apply Un (map -val args))) + (define-initial-env initial-env ;; make-promise @@ -145,9 +148,13 @@ [string-append (->* null -String -String)] [open-input-string (-> -String -Input-Port)] [open-output-file - (cl-> - [(-Pathlike) -Port] - [(-Pathlike Sym) -Port])] + (->key -Pathlike + #:mode (one-of/c 'binary 'text) #f + #:exists (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace) + #f + -Output-Port)] [read (cl-> [(-Port) -Sexp] [() -Sexp])] @@ -205,9 +212,7 @@ [remove* (-poly (a b) (cl-> [((-lst a) (-lst a)) (-lst a)] [((-lst a) (-lst b) (a b . -> . B)) (-lst b)]))] - - [call-with-values (-poly (a b) (-> (-> a) (-> a b) b))] - + (error (make-Function (list (make-arr null (Un)) @@ -246,7 +251,6 @@ (- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N))) (max (->* (list N) N N)) (min (->* (list N) N N)) - [values (make-Poly '(a) (-> (-v a) (-v a)))] [vector-ref (make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))] [build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))] @@ -467,7 +471,7 @@ [(-Bytes N) -Bytes] [(-Bytes N N) -Bytes])] [bytes-length (-> -Bytes N)] - [open-input-file (-> -Pathlike -Input-Port)] + [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)] [close-input-port (-> -Input-Port -Void)] [close-output-port (-> -Output-Port -Void)] [read-line (cl-> @@ -553,10 +557,10 @@ [syntax-property (-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a)) (-> (-Syntax Univ) Univ Univ)))] - [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] - [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] + [values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] + [call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] - [foo (make-Function (list (make-arr (list N) B #f #f (list (make-Keyword '#:bar B #f)) null null)))] + [foo (N #:bar B #f . ->key . B)] ) (begin-for-syntax diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index a4771751..06ed3c4b 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -9,6 +9,7 @@ "type-utils.ss" "tc-utils.ss" scheme/promise + (for-syntax macro-debugger/stxclass/stxclass) (for-syntax scheme/base)) (provide (all-defined-out)) @@ -78,12 +79,26 @@ [(Function: as) as])) (make-Function (map car (map funty-arities args)))) +(define-syntax (->key stx) + (syntax-parse stx + [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) + #'(make-Function + (list + (make-arr* (list ty ...) + rng + #f + #f + (list (make-Keyword 'k kty opt) ...) + null + null)))])) + (define make-arr* - (case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))] + (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))] [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)] - [(dom rng rest drest kws eff1 eff2) (make-arr dom rng rest drest kws eff1 eff2)])) + [(dom rng rest drest kws eff1 eff2) + (make-arr dom rng rest drest (sort #:key Keyword-kw kws keyword Date: Mon, 8 Sep 2008 13:27:38 -0400 Subject: [PATCH 5/8] Improve errors. original commit: 8df7a464931969dd782f3efe6db7e322643be2f4 --- collects/typed-scheme/private/free-variance.ss | 4 ++-- collects/typed-scheme/private/parse-type.ss | 2 +- collects/typed-scheme/private/tc-utils.ss | 2 +- collects/typed-scheme/private/type-effect-convenience.ss | 2 +- collects/typed-scheme/private/type-rep.ss | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/typed-scheme/private/free-variance.ss b/collects/typed-scheme/private/free-variance.ss index db9cb4f8..8d476558 100644 --- a/collects/typed-scheme/private/free-variance.ss +++ b/collects/typed-scheme/private/free-variance.ss @@ -27,8 +27,8 @@ (define var-table (make-weak-hasheq)) ;; maps Type to List[Cons[Symbol,Variance]] -(define (free-idxs* t) (hash-ref index-table t (lambda _ (error "type not in index-table" (syntax-e t))))) -(define (free-vars* t) (hash-ref var-table t (lambda _ (error "type not in var-table" (syntax-e t))))) +(define (free-idxs* t) (hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" (syntax-e t))))) +(define (free-vars* t) (hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" (syntax-e t))))) (define empty-hash-table (make-immutable-hasheq null)) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 2b92c493..0885e9c8 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -213,7 +213,7 @@ ;(printf "found a type name ~a~n" #'id) (make-Name #'id)] [else - (tc-error/delayed "unbound type ~a" (syntax-e #'id)) + (tc-error/delayed "unbound type name ~a" (syntax-e #'id)) Univ])] [(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")] diff --git a/collects/typed-scheme/private/tc-utils.ss b/collects/typed-scheme/private/tc-utils.ss index 3e44382e..132b2206 100644 --- a/collects/typed-scheme/private/tc-utils.ss +++ b/collects/typed-scheme/private/tc-utils.ss @@ -75,7 +75,7 @@ (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest) (let ([stx (locate-stx stx*)]) (unless (syntax? stx) - (error "syntax was not syntax" stx (syntax->datum stx*))) + (int-err "erroneous syntax was not a syntax object: ~a ~a" stx (syntax->datum stx*))) (if (delay-errors?) (set! delayed-errors (cons (make-err (apply format msg rest) (list stx)) delayed-errors)) (raise-typecheck-error (apply format msg rest) (list stx))))) diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 06ed3c4b..0eb73bcd 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -34,7 +34,7 @@ [(Latent-Remove-Effect: t) (make-Remove-Effect t v)] [(True-Effect:) eff] [(False-Effect:) eff] - [_ (error 'internal-tc-error "can't add var to effect ~a" eff)])) + [_ (int-err "can't add var ~a to effect ~a" v eff)])) (define-syntax (-> stx) (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) diff --git a/collects/typed-scheme/private/type-rep.ss b/collects/typed-scheme/private/type-rep.ss index c63a2a8f..889d0dd5 100644 --- a/collects/typed-scheme/private/type-rep.ss +++ b/collects/typed-scheme/private/type-rep.ss @@ -422,7 +422,7 @@ (match t [(Poly: n scope) (unless (= (length names) n) - (error "Wrong number of names")) + (int-err "Wrong number of names: expected ~a got ~a" n (length names))) (instantiate-many (map *F names) scope)])) ;; the 'smart' constructor @@ -437,7 +437,7 @@ (match t [(PolyDots: n scope) (unless (= (length names) n) - (error "Wrong number of names")) + (int-err "Wrong number of names: expected ~a got ~a" n (length names))) (instantiate-many (map *F names) scope)])) (print-struct #t) From f54d1632241da688835978f3ddd05746a8e440d3 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 9 Sep 2008 17:40:26 -0400 Subject: [PATCH 6/8] reorg original commit: 5ac64589baffabf3e7045e5c0c877a1c484207ea --- .../{private => env}/init-envs.ss | 15 +++++--- .../{private => env}/lexical-env.ss | 8 ++++- .../{private => env}/type-alias-env.ss | 3 +- .../typed-scheme/{private => env}/type-env.ss | 4 ++- .../{private => env}/type-environments.ss | 3 +- .../{private => env}/type-name-env.ss | 5 +-- .../{private => infer}/constraint-structs.ss | 3 +- .../{private => infer}/constraints.ss | 7 ++-- .../typed-scheme/{private => infer}/dmap.ss | 4 ++- .../{private => infer}/infer-unit.ss | 14 ++++---- .../typed-scheme/{private => infer}/infer.ss | 3 +- .../{private => infer}/promote-demote.ss | 7 ++-- .../{private => infer}/restrict.ss | 6 ++-- collects/typed-scheme/infer/signatures.ss | 29 ++++++++++++++++ collects/typed-scheme/private/base-env.ss | 8 ++--- collects/typed-scheme/private/base-types.ss | 5 +-- collects/typed-scheme/private/parse-type.ss | 11 +++--- collects/typed-scheme/private/prims.ss | 10 +++--- .../typed-scheme/private/remove-intersect.ss | 5 +-- collects/typed-scheme/private/resolve-type.ss | 3 +- collects/typed-scheme/private/subtype.ss | 11 +++--- .../typed-scheme/private/type-annotation.ss | 8 +++-- .../private/type-effect-convenience.ss | 7 ++-- .../private/type-effect-printer.ss | 6 +++- collects/typed-scheme/private/type-utils.ss | 10 +++--- collects/typed-scheme/private/union.ss | 8 +++-- .../{private => rep}/effect-rep.ss | 0 .../{private => rep}/free-variance.ss | 3 +- .../{private => rep}/interning.ss | 0 .../{private => rep}/rep-utils.ss | 6 ++-- .../typed-scheme/{private => rep}/type-rep.ss | 5 +-- .../check-subforms-unit.ss | 11 +++--- .../{private => typecheck}/def-binding.ss | 0 .../{private => typecheck}/internal-forms.ss | 0 .../provide-handling.ss | 7 ++-- .../{private => typecheck}/signatures.ss | 32 +---------------- .../{private => typecheck}/tc-app-unit.ss | 22 +++++------- .../{private => typecheck}/tc-expr-unit.ss | 18 ++++------ .../{private => typecheck}/tc-lambda-unit.ss | 17 ++++------ .../{private => typecheck}/tc-let-unit.ss | 11 ++---- .../{private => typecheck}/tc-structs.ss | 17 ++++------ .../{private => typecheck}/tc-toplevel.ss | 19 +++-------- .../{private => typecheck}/typechecker.ss | 3 +- collects/typed-scheme/typed-scheme.ss | 26 ++++++-------- .../{private => utils}/tc-utils.ss | 0 .../typed-scheme/{private => utils}/utils.ss | 34 ++++++++++++++++++- 46 files changed, 234 insertions(+), 200 deletions(-) rename collects/typed-scheme/{private => env}/init-envs.ss (90%) rename collects/typed-scheme/{private => env}/lexical-env.ss (90%) rename collects/typed-scheme/{private => env}/type-alias-env.ss (96%) rename collects/typed-scheme/{private => env}/type-env.ss (95%) rename collects/typed-scheme/{private => env}/type-environments.ss (96%) rename collects/typed-scheme/{private => env}/type-name-env.ss (93%) rename collects/typed-scheme/{private => infer}/constraint-structs.ss (94%) rename collects/typed-scheme/{private => infer}/constraints.ss (94%) rename collects/typed-scheme/{private => infer}/dmap.ss (92%) rename collects/typed-scheme/{private => infer}/infer-unit.ss (98%) rename collects/typed-scheme/{private => infer}/infer.ss (67%) rename collects/typed-scheme/{private => infer}/promote-demote.ss (96%) rename collects/typed-scheme/{private => infer}/restrict.ss (90%) create mode 100644 collects/typed-scheme/infer/signatures.ss rename collects/typed-scheme/{private => rep}/effect-rep.ss (100%) rename collects/typed-scheme/{private => rep}/free-variance.ss (98%) rename collects/typed-scheme/{private => rep}/interning.ss (100%) rename collects/typed-scheme/{private => rep}/rep-utils.ss (98%) rename collects/typed-scheme/{private => rep}/type-rep.ss (99%) rename collects/typed-scheme/{private => typecheck}/check-subforms-unit.ss (92%) rename collects/typed-scheme/{private => typecheck}/def-binding.ss (100%) rename collects/typed-scheme/{private => typecheck}/internal-forms.ss (100%) rename collects/typed-scheme/{private => typecheck}/provide-handling.ss (96%) rename collects/typed-scheme/{private => typecheck}/signatures.ss (51%) rename collects/typed-scheme/{private => typecheck}/tc-app-unit.ss (98%) rename collects/typed-scheme/{private => typecheck}/tc-expr-unit.ss (96%) rename collects/typed-scheme/{private => typecheck}/tc-lambda-unit.ss (96%) rename collects/typed-scheme/{private => typecheck}/tc-let-unit.ss (96%) rename collects/typed-scheme/{private => typecheck}/tc-structs.ss (95%) rename collects/typed-scheme/{private => typecheck}/tc-toplevel.ss (94%) rename collects/typed-scheme/{private => typecheck}/typechecker.ss (89%) rename collects/typed-scheme/{private => utils}/tc-utils.ss (100%) rename collects/typed-scheme/{private => utils}/utils.ss (86%) diff --git a/collects/typed-scheme/private/init-envs.ss b/collects/typed-scheme/env/init-envs.ss similarity index 90% rename from collects/typed-scheme/private/init-envs.ss rename to collects/typed-scheme/env/init-envs.ss index d0dac77c..4a03b910 100644 --- a/collects/typed-scheme/private/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -1,11 +1,16 @@ #lang scheme/base (provide (all-defined-out)) +(require "../utils/utils.ss") -(require "type-env.ss" "type-rep.ss" "type-name-env.ss" "union.ss" "effect-rep.ss" - "type-effect-convenience.ss" "type-alias-env.ss" - "type-alias-env.ss") -(require mzlib/pconvert scheme/match mzlib/shared - (for-template mzlib/pconvert mzlib/shared scheme/base "type-rep.ss" "union.ss" "effect-rep.ss")) +(require "type-env.ss" + "type-name-env.ss" + (rep type-rep effect-rep) + (for-template (rep type-rep effect-rep) + (private union) + mzlib/pconvert mzlib/shared scheme/base) + (private type-effect-convenience union) + "type-alias-env.ss" + mzlib/pconvert scheme/match mzlib/shared) (define (initialize-type-name-env initial-type-names) (for-each (lambda (nm/ty) (register-resolved-type-alias (car nm/ty) (cadr nm/ty))) initial-type-names)) diff --git a/collects/typed-scheme/private/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss similarity index 90% rename from collects/typed-scheme/private/lexical-env.ss rename to collects/typed-scheme/env/lexical-env.ss index e5946a31..63a1295b 100644 --- a/collects/typed-scheme/private/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -1,6 +1,12 @@ #lang scheme/base -(require "type-environments.ss" "tc-utils.ss" "type-env.ss" "mutated-vars.ss" "type-utils.ss" "type-effect-convenience.ss") +(require (except-in "../utils/utils.ss" extend)) +(require "type-environments.ss" + (utils tc-utils) + "type-env.ss" + (private mutated-vars) + (private type-utils) + (private type-effect-convenience)) (provide (all-defined-out)) diff --git a/collects/typed-scheme/private/type-alias-env.ss b/collects/typed-scheme/env/type-alias-env.ss similarity index 96% rename from collects/typed-scheme/private/type-alias-env.ss rename to collects/typed-scheme/env/type-alias-env.ss index 0be4da74..dd9183d3 100644 --- a/collects/typed-scheme/private/type-alias-env.ss +++ b/collects/typed-scheme/env/type-alias-env.ss @@ -1,7 +1,8 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap - "tc-utils.ss" + (utils tc-utils) mzlib/trace scheme/match) diff --git a/collects/typed-scheme/private/type-env.ss b/collects/typed-scheme/env/type-env.ss similarity index 95% rename from collects/typed-scheme/private/type-env.ss rename to collects/typed-scheme/env/type-env.ss index d9dafeef..59eb3cad 100644 --- a/collects/typed-scheme/private/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -1,7 +1,9 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap - "tc-utils.ss" "type-utils.ss") + (utils tc-utils) + (private type-utils)) (provide register-type finish-register-type diff --git a/collects/typed-scheme/private/type-environments.ss b/collects/typed-scheme/env/type-environments.ss similarity index 96% rename from collects/typed-scheme/private/type-environments.ss rename to collects/typed-scheme/env/type-environments.ss index 536fdfc9..0f159ec0 100644 --- a/collects/typed-scheme/private/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -10,8 +10,9 @@ initial-tvar-env with-dotted-env/extend) +(require (prefix-in r: "../utils/utils.ss")) (require scheme/match - "tc-utils.ss") + (r:utils tc-utils)) ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) diff --git a/collects/typed-scheme/private/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss similarity index 93% rename from collects/typed-scheme/private/type-name-env.ss rename to collects/typed-scheme/env/type-name-env.ss index 370b77e7..d6773f0e 100644 --- a/collects/typed-scheme/private/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require "../utils/utils.ss") (require syntax/boundmap mzlib/trace - "tc-utils.ss" - "type-utils.ss") + (utils tc-utils) + (private type-utils)) (provide register-type-name lookup-type-name diff --git a/collects/typed-scheme/private/constraint-structs.ss b/collects/typed-scheme/infer/constraint-structs.ss similarity index 94% rename from collects/typed-scheme/private/constraint-structs.ss rename to collects/typed-scheme/infer/constraint-structs.ss index def84ae0..d5c97034 100644 --- a/collects/typed-scheme/private/constraint-structs.ss +++ b/collects/typed-scheme/infer/constraint-structs.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require "type-rep.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) scheme/contract) ;; S, T types diff --git a/collects/typed-scheme/private/constraints.ss b/collects/typed-scheme/infer/constraints.ss similarity index 94% rename from collects/typed-scheme/private/constraints.ss rename to collects/typed-scheme/infer/constraints.ss index 2697109e..3dff2c08 100644 --- a/collects/typed-scheme/private/constraints.ss +++ b/collects/typed-scheme/infer/constraints.ss @@ -1,8 +1,9 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" - "type-utils.ss" "union.ss" "tc-utils.ss" - "subtype.ss" "utils.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (private type-effect-convenience type-utils union subtype) + (rep type-rep) + (utils tc-utils) "signatures.ss" "constraint-structs.ss" scheme/match) diff --git a/collects/typed-scheme/private/dmap.ss b/collects/typed-scheme/infer/dmap.ss similarity index 92% rename from collects/typed-scheme/private/dmap.ss rename to collects/typed-scheme/infer/dmap.ss index ef2112ba..95926680 100644 --- a/collects/typed-scheme/private/dmap.ss +++ b/collects/typed-scheme/infer/dmap.ss @@ -1,6 +1,8 @@ #lang scheme/unit -(require "signatures.ss" "utils.ss" "tc-utils.ss" "constraint-structs.ss" +(require (except-in "../utils/utils.ss" extend)) +(require "signatures.ss" "constraint-structs.ss" + (utils tc-utils) scheme/match) (import constraints^) diff --git a/collects/typed-scheme/private/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss similarity index 98% rename from collects/typed-scheme/private/infer-unit.ss rename to collects/typed-scheme/infer/infer-unit.ss index b9590895..c640d363 100644 --- a/collects/typed-scheme/private/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -1,12 +1,14 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" "effect-rep.ss" "rep-utils.ss" - "free-variance.ss" - (except-in "type-utils.ss" Dotted) - "union.ss" "tc-utils.ss" "type-name-env.ss" - "subtype.ss" "remove-intersect.ss" "signatures.ss" "utils.ss" +(require (except-in "../utils/utils.ss")) +(require (rep free-variance type-rep effect-rep rep-utils) + (private type-effect-convenience union subtype remove-intersect) + (utils tc-utils) + (env type-name-env) + (except-in (private type-utils) Dotted) "constraint-structs.ss" - (only-in "type-environments.ss" lookup current-tvars) + "signatures.ss" + (only-in (env type-environments) lookup current-tvars) scheme/match mzlib/etc mzlib/trace diff --git a/collects/typed-scheme/private/infer.ss b/collects/typed-scheme/infer/infer.ss similarity index 67% rename from collects/typed-scheme/private/infer.ss rename to collects/typed-scheme/infer/infer.ss index d860e5f5..208943a3 100644 --- a/collects/typed-scheme/private/infer.ss +++ b/collects/typed-scheme/infer/infer.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" infer)) (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss" "restrict.ss" "promote-demote.ss" (only-in scheme/unit provide-signature-elements) - "unit-utils.ss") + (utils unit-utils)) (provide-signature-elements restrict^ infer^) diff --git a/collects/typed-scheme/private/promote-demote.ss b/collects/typed-scheme/infer/promote-demote.ss similarity index 96% rename from collects/typed-scheme/private/promote-demote.ss rename to collects/typed-scheme/infer/promote-demote.ss index d24eda82..87051229 100644 --- a/collects/typed-scheme/private/promote-demote.ss +++ b/collects/typed-scheme/infer/promote-demote.ss @@ -1,8 +1,9 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" - "type-utils.ss" "union.ss" - "signatures.ss" "utils.ss" +(require "../utils/utils.ss") +(require (rep type-rep) + (private type-effect-convenience union type-utils) + "signatures.ss" scheme/list) (import) diff --git a/collects/typed-scheme/private/restrict.ss b/collects/typed-scheme/infer/restrict.ss similarity index 90% rename from collects/typed-scheme/private/restrict.ss rename to collects/typed-scheme/infer/restrict.ss index 2c86a687..e1365605 100644 --- a/collects/typed-scheme/private/restrict.ss +++ b/collects/typed-scheme/infer/restrict.ss @@ -1,8 +1,8 @@ #lang scheme/unit -(require "type-rep.ss" - "type-utils.ss" "union.ss" - "subtype.ss" "remove-intersect.ss" +(require "../utils/utils.ss") +(require (rep type-rep) + (private type-utils union remove-intersect subtype) "signatures.ss" scheme/match) diff --git a/collects/typed-scheme/infer/signatures.ss b/collects/typed-scheme/infer/signatures.ss new file mode 100644 index 00000000..6db02b38 --- /dev/null +++ b/collects/typed-scheme/infer/signatures.ss @@ -0,0 +1,29 @@ +#lang scheme/base +(require scheme/unit) +(provide (all-defined-out)) + +(define-signature dmap^ + (dmap-meet)) + +(define-signature promote-demote^ + (var-promote var-demote)) + +(define-signature constraints^ + (exn:infer? + fail-sym + ;; inference failure - masked before it gets to the user program + (define-syntaxes (fail!) + (syntax-rules () + [(_ s t) (raise fail-sym)])) + cset-meet cset-meet* + no-constraint + empty-cset + insert + cset-combine + c-meet)) + +(define-signature restrict^ + (restrict)) + +(define-signature infer^ + (infer infer/vararg infer/dots)) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 5703eb4f..719c25ba 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -3,6 +3,7 @@ ;; these are libraries providing functions we add types to that are not in scheme/base (require "extra-procs.ss" + "../utils/utils.ss" (only-in scheme/list cons? take drop add-between last filter-map) (only-in rnrs/lists-6 fold-left) '#%paramz @@ -15,13 +16,12 @@ ;; these are all for constructing the types given to variables (require (for-syntax scheme/base - "init-envs.ss" - "effect-rep.ss" - (except-in "type-rep.ss" make-arr) + (env init-envs) + (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" - "tc-structs.ss")) + (typecheck tc-structs))) (define-for-syntax (initialize-others) (d-s date diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss index cc4bb42a..6058fd4b 100644 --- a/collects/typed-scheme/private/base-types.ss +++ b/collects/typed-scheme/private/base-types.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - "init-envs.ss" - (except-in "type-rep.ss" make-arr) + (env init-envs) + (except-in (rep type-rep) make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss")) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 0885e9c8..07adfd9e 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -2,16 +2,15 @@ (provide parse-type parse-type/id) -(require (except-in "type-rep.ss" make-arr) +(require (except-in "../utils/utils.ss" extend)) +(require (except-in (rep type-rep) make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - "tc-utils.ss" + (utils tc-utils) "union.ss" syntax/stx - (except-in "type-environments.ss") - "type-name-env.ss" - "type-alias-env.ss" - "type-utils.ss" + (env type-environments type-name-env type-alias-env) + "type-utils.ss" scheme/match) (define enable-mu-parsing (make-parameter #t)) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index ef3e7cc5..9068659c 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -22,20 +22,20 @@ This file defines two sorts of primitives. All of them are provided into any mod (provide (all-defined-out) (rename-out [define-typed-struct define-struct:])) +(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - "type-rep.ss" + (rep type-rep) mzlib/match "parse-type.ss" syntax/struct syntax/stx - "utils.ss" - "tc-utils.ss" - "type-name-env.ss" + (utils utils tc-utils) + (env type-name-env) "type-contract.ss")) (require "require-contract.ss" - "internal-forms.ss" + (typecheck internal-forms) (except-in mzlib/contract ->) (only-in mzlib/contract [-> c->]) mzlib/struct diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/private/remove-intersect.ss index f9b273e8..d244fb73 100644 --- a/collects/typed-scheme/private/remove-intersect.ss +++ b/collects/typed-scheme/private/remove-intersect.ss @@ -1,7 +1,8 @@ #lang scheme/base -(require "type-rep.ss" "union.ss" "subtype.ss" - "type-utils.ss" "resolve-type.ss" "type-effect-convenience.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (private union subtype resolve-type type-effect-convenience type-utils) mzlib/plt-match mzlib/trace) (provide (rename-out [*remove remove]) overlap) diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/private/resolve-type.ss index d68de692..6526a428 100644 --- a/collects/typed-scheme/private/resolve-type.ss +++ b/collects/typed-scheme/private/resolve-type.ss @@ -1,6 +1,7 @@ #lang scheme/base +(require "../utils/utils.ss") -(require "type-rep.ss" "type-name-env.ss" "tc-utils.ss" +(require (rep type-rep) (env type-name-env) (utils tc-utils) "type-utils.ss" mzlib/plt-match mzlib/trace) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 3667f421..1db8c33b 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -1,12 +1,13 @@ #lang scheme/base +(require "../utils/utils.ss") -(require (except-in "type-rep.ss" sub-eff) "type-utils.ss" - "tc-utils.ss" - "effect-rep.ss" +(require (except-in (rep type-rep effect-rep) sub-eff) + (utils tc-utils) + "type-utils.ss" "type-comparison.ss" "resolve-type.ss" - "type-name-env.ss" - (only-in "infer-dummy.ss" unify) + (env type-name-env) + (only-in (infer infer-dummy) unify) mzlib/plt-match mzlib/trace) diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index 1a72e73b..bbb83034 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -1,7 +1,11 @@ #lang scheme/base -(require "type-rep.ss" "parse-type.ss" "tc-utils.ss" "subtype.ss" "utils.ss" - "type-env.ss" "type-effect-convenience.ss" "resolve-type.ss" "union.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (utils tc-utils) + (env type-env) + "parse-type.ss" "subtype.ss" + "type-effect-convenience.ss" "resolve-type.ss" "union.ss" scheme/match mzlib/trace) (provide type-annotation get-type diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 0eb73bcd..13aa199c 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -1,13 +1,14 @@ #lang scheme/base -(require "type-rep.ss" - "effect-rep.ss" +(require "../utils/utils.ss") + +(require (rep type-rep effect-rep) + (utils tc-utils) scheme/match "type-comparison.ss" "type-effect-printer.ss" "union.ss" "subtype.ss" "type-utils.ss" - "tc-utils.ss" scheme/promise (for-syntax macro-debugger/stxclass/stxclass) (for-syntax scheme/base)) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index 72038bb8..812f58a6 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -1,5 +1,9 @@ #lang scheme/base -(require "type-rep.ss" "effect-rep.ss" "rep-utils.ss" "tc-utils.ss" "planet-requires.ss" scheme/match) + +(require "../utils/utils.ss") +(require (rep type-rep effect-rep rep-utils) + (utils planet-requires tc-utils) + scheme/match) ;; do we attempt to find instantiations of polymorphic types to print? ;; FIXME - currently broken diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index 9c53cfa0..d74c89e0 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -1,10 +1,10 @@ #lang scheme/base -(require "type-rep.ss" - "effect-rep.ss" - "tc-utils.ss" - "rep-utils.ss" - (only-in "free-variance.ss" combine-frees) +(require "../utils/utils.ss") + +(require (rep type-rep effect-rep rep-utils) + (utils tc-utils) + (only-in (rep free-variance) combine-frees) mzlib/plt-match scheme/list mzlib/trace diff --git a/collects/typed-scheme/private/union.ss b/collects/typed-scheme/private/union.ss index 02a1a271..d2235d65 100644 --- a/collects/typed-scheme/private/union.ss +++ b/collects/typed-scheme/private/union.ss @@ -1,7 +1,11 @@ #lang scheme/base -(require "type-rep.ss" "subtype.ss" "tc-utils.ss" - "type-effect-printer.ss" "rep-utils.ss" +(require "../utils/utils.ss") + +(require (rep type-rep rep-utils) + (utils tc-utils) + "subtype.ss" + "type-effect-printer.ss" "type-comparison.ss" scheme/match mzlib/trace) diff --git a/collects/typed-scheme/private/effect-rep.ss b/collects/typed-scheme/rep/effect-rep.ss similarity index 100% rename from collects/typed-scheme/private/effect-rep.ss rename to collects/typed-scheme/rep/effect-rep.ss diff --git a/collects/typed-scheme/private/free-variance.ss b/collects/typed-scheme/rep/free-variance.ss similarity index 98% rename from collects/typed-scheme/private/free-variance.ss rename to collects/typed-scheme/rep/free-variance.ss index 8d476558..7e4014e3 100644 --- a/collects/typed-scheme/private/free-variance.ss +++ b/collects/typed-scheme/rep/free-variance.ss @@ -1,7 +1,8 @@ #lang scheme/base +(require "../utils/utils.ss") (require (for-syntax scheme/base) - "tc-utils.ss" + (utils tc-utils) mzlib/etc) ;; this file contains support for calculating the free variables/indexes of types diff --git a/collects/typed-scheme/private/interning.ss b/collects/typed-scheme/rep/interning.ss similarity index 100% rename from collects/typed-scheme/private/interning.ss rename to collects/typed-scheme/rep/interning.ss diff --git a/collects/typed-scheme/private/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss similarity index 98% rename from collects/typed-scheme/private/rep-utils.ss rename to collects/typed-scheme/rep/rep-utils.ss index cd1d21b5..2f49dba9 100644 --- a/collects/typed-scheme/private/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -1,18 +1,18 @@ #lang scheme/base +(require "../utils/utils.ss") (require mzlib/struct mzlib/plt-match syntax/boundmap - "planet-requires.ss" + (utils planet-requires) "free-variance.ss" - "utils.ss" "interning.ss" mzlib/etc (for-syntax scheme/base syntax/struct syntax/stx - "utils.ss")) + (utils utils))) (provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq) diff --git a/collects/typed-scheme/private/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss similarity index 99% rename from collects/typed-scheme/private/type-rep.ss rename to collects/typed-scheme/rep/type-rep.ss index 889d0dd5..9ced9791 100644 --- a/collects/typed-scheme/private/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -1,7 +1,8 @@ #lang scheme/base +(require "../utils/utils.ss") -(require "planet-requires.ss" "rep-utils.ss" "effect-rep.ss" "tc-utils.ss" - "free-variance.ss" +(require (utils planet-requires tc-utils) + "rep-utils.ss" "effect-rep.ss" "free-variance.ss" mzlib/trace scheme/match (for-syntax scheme/base)) diff --git a/collects/typed-scheme/private/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss similarity index 92% rename from collects/typed-scheme/private/check-subforms-unit.ss rename to collects/typed-scheme/typecheck/check-subforms-unit.ss index 554bbea1..e37c6f37 100644 --- a/collects/typed-scheme/private/check-subforms-unit.ss +++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss @@ -1,15 +1,12 @@ #lang scheme/unit +(require (except-in "../utils/utils.ss" extend)) (require syntax/kerncase scheme/match "signatures.ss" - "type-utils.ss" - "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "union.ss" - "subtype.ss" ;; has tests - "tc-utils.ss" ;; doesn't need tests - ) + (private type-utils type-effect-convenience union subtype) + (utils tc-utils) + (rep type-rep)) (import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^) (export check-subforms^) diff --git a/collects/typed-scheme/private/def-binding.ss b/collects/typed-scheme/typecheck/def-binding.ss similarity index 100% rename from collects/typed-scheme/private/def-binding.ss rename to collects/typed-scheme/typecheck/def-binding.ss diff --git a/collects/typed-scheme/private/internal-forms.ss b/collects/typed-scheme/typecheck/internal-forms.ss similarity index 100% rename from collects/typed-scheme/private/internal-forms.ss rename to collects/typed-scheme/typecheck/internal-forms.ss diff --git a/collects/typed-scheme/private/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss similarity index 96% rename from collects/typed-scheme/private/provide-handling.ss rename to collects/typed-scheme/typecheck/provide-handling.ss index 1d4f67bf..4ca36a34 100644 --- a/collects/typed-scheme/private/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -1,11 +1,12 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require (only-in srfi/1/list s:member) syntax/kerncase mzlib/trace - "type-contract.ss" - "type-rep.ss" - "tc-utils.ss" + (private type-contract) + (rep type-rep) + (utils tc-utils) "def-binding.ss") (require (for-template scheme/base diff --git a/collects/typed-scheme/private/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss similarity index 51% rename from collects/typed-scheme/private/signatures.ss rename to collects/typed-scheme/typecheck/signatures.ss index 9f8b0dba..b5ab6ebc 100644 --- a/collects/typed-scheme/private/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -2,41 +2,11 @@ (require scheme/unit) (provide (all-defined-out)) -(define-signature dmap^ - (dmap-meet)) - -(define-signature promote-demote^ - (var-promote var-demote)) - -(define-signature constraints^ - (exn:infer? - fail-sym - ;; inference failure - masked before it gets to the user program - (define-syntaxes (fail!) - (syntax-rules () - [(_ s t) (raise fail-sym)])) - cset-meet cset-meet* - no-constraint - empty-cset - insert - cset-combine - c-meet)) - -(define-signature restrict^ - (restrict)) - -(define-signature infer^ - (infer infer/vararg infer/dots)) - - - -;; cycle 2 - (define-signature typechecker^ (type-check tc-toplevel-form)) (define-signature tc-expr^ - (tc-expr tc-expr/check tc-expr/check/t check-below tc-literal tc-exprs tc-exprs/check tc-expr/t #;check-expr)) + (tc-expr tc-expr/check tc-expr/check/t check-below tc-exprs tc-exprs/check tc-expr/t)) (define-signature check-subforms^ (check-subforms/ignore check-subforms/with-handlers check-subforms/with-handlers/check)) diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss similarity index 98% rename from collects/typed-scheme/private/tc-app-unit.ss rename to collects/typed-scheme/typecheck/tc-app-unit.ss index 5d8afe8a..3c04db14 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -1,19 +1,13 @@ #lang scheme/unit +(require (only-in "../utils/utils.ss" debug in-syntax printf/log in-pairs rep utils private env [infer r:infer])) (require "signatures.ss" - "type-rep.ss" - "effect-rep.ss" - "tc-utils.ss" - "subtype.ss" - "infer.ss" - (only-in "utils.ss" debug in-syntax printf/log in-pairs) - "union.ss" - "type-utils.ss" - "type-effect-convenience.ss" - "type-effect-printer.ss" - "type-annotation.ss" - "resolve-type.ss" - "type-environments.ss" + (rep type-rep effect-rep) + (utils tc-utils) + (private subtype type-utils union type-effect-convenience type-effect-printer resolve-type + type-annotation) + (r:infer infer) + (env type-environments) (only-in srfi/1 alist-delete) (only-in scheme/private/class-internal make-object do-make-object) mzlib/trace mzlib/pretty syntax/kerncase scheme/match @@ -21,7 +15,7 @@ (for-template "internal-forms.ss" scheme/base (only-in scheme/private/class-internal make-object do-make-object))) -(require "constraint-structs.ss") +(require (r:infer constraint-structs)) (import tc-expr^ tc-lambda^ tc-dots^) (export tc-app^) diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss similarity index 96% rename from collects/typed-scheme/private/tc-expr-unit.ss rename to collects/typed-scheme/typecheck/tc-expr-unit.ss index 163fa343..7e32c0c7 100644 --- a/collects/typed-scheme/private/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -1,21 +1,15 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [private r:private])) (require syntax/kerncase scheme/match "signatures.ss" - "type-utils.ss" - "utils.ss" ;; doesn't need tests - "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "union.ss" - "subtype.ss" ;; has tests - "parse-type.ss" ;; has tests - "tc-utils.ss" ;; doesn't need tests - "lexical-env.ss" ;; maybe needs tests - "type-annotation.ss" ;; has tests - "effect-rep.ss" - (only-in "type-environments.ss" lookup current-tvars extend-env) + (r:private type-utils type-effect-convenience union subtype parse-type type-annotation) + (rep type-rep effect-rep) + (utils tc-utils) + (env lexical-env) + (only-in (env type-environments) lookup current-tvars extend-env) scheme/private/class-internal (only-in srfi/1 split-at)) diff --git a/collects/typed-scheme/private/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss similarity index 96% rename from collects/typed-scheme/private/tc-lambda-unit.ss rename to collects/typed-scheme/typecheck/tc-lambda-unit.ss index 455d6acd..962c480e 100644 --- a/collects/typed-scheme/private/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -1,20 +1,15 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) (require "signatures.ss" mzlib/trace scheme/list - (except-in "type-rep.ss" make-arr) ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "type-environments.ss" ;; doesn't need tests - "lexical-env.ss" ;; maybe needs tests - "type-annotation.ss" ;; has tests - (except-in "utils.ss" extend) - "type-utils.ss" - "effect-rep.ss" - "tc-utils.ss" - "union.ss" + (except-in (rep type-rep effect-rep) make-arr) ;; doesn't need tests + (private type-effect-convenience type-annotation union type-utils) + (env type-environments lexical-env) + (utils tc-utils) mzlib/plt-match - (only-in "type-effect-convenience.ss" [make-arr* make-arr])) + (only-in (private type-effect-convenience) [make-arr* make-arr])) (require (for-template scheme/base "internal-forms.ss")) (import tc-expr^) diff --git a/collects/typed-scheme/private/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss similarity index 96% rename from collects/typed-scheme/private/tc-let-unit.ss rename to collects/typed-scheme/typecheck/tc-let-unit.ss index eb292852..9bf2bf3f 100644 --- a/collects/typed-scheme/private/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -1,14 +1,9 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer])) (require "signatures.ss" - "type-effect-convenience.ss" - "lexical-env.ss" - "type-annotation.ss" - "type-alias-env.ss" - "type-env.ss" - "parse-type.ss" - "utils.ss" - "type-utils.ss" + (private type-effect-convenience type-annotation parse-type type-utils) + (env lexical-env type-alias-env type-env) syntax/free-vars mzlib/trace scheme/match diff --git a/collects/typed-scheme/private/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss similarity index 95% rename from collects/typed-scheme/private/tc-structs.ss rename to collects/typed-scheme/typecheck/tc-structs.ss index 23c8a430..86233c0d 100644 --- a/collects/typed-scheme/private/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -1,15 +1,12 @@ #lang scheme/base -(require "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "type-env.ss" ;; maybe needs tests - "type-utils.ss" - "parse-type.ss" ;; has tests - "type-environments.ss" ;; doesn't need tests - "type-name-env.ss" ;; maybe needs tests - "union.ss" - "tc-utils.ss" - "resolve-type.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (private type-effect-convenience + type-utils parse-type + union resolve-type) + (env type-env type-environments type-name-env) + (utils tc-utils) "def-binding.ss" syntax/kerncase syntax/struct diff --git a/collects/typed-scheme/private/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss similarity index 94% rename from collects/typed-scheme/private/tc-toplevel.ss rename to collects/typed-scheme/typecheck/tc-toplevel.ss index 23b3614c..5f2d36f2 100644 --- a/collects/typed-scheme/private/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -1,26 +1,17 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer])) (require syntax/kerncase mzlib/etc scheme/match "signatures.ss" "tc-structs.ss" - "type-utils.ss" - "utils.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "internal-forms.ss" ;; doesn't need tests - "type-env.ss" ;; maybe needs tests - "parse-type.ss" ;; has tests - "tc-utils.ss" ;; doesn't need tests - "type-annotation.ss" ;; has tests - "type-name-env.ss" ;; maybe needs tests - "init-envs.ss" - "mutated-vars.ss" + (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract) + (env type-env init-envs type-name-env type-alias-env) + (utils tc-utils) + "provide-handling.ss" "def-binding.ss" - "provide-handling.ss" - "type-alias-env.ss" - "type-contract.ss" (for-template "internal-forms.ss" mzlib/contract diff --git a/collects/typed-scheme/private/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss similarity index 89% rename from collects/typed-scheme/private/typechecker.ss rename to collects/typed-scheme/typecheck/typechecker.ss index 3ec16bcf..ed935ff9 100644 --- a/collects/typed-scheme/private/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require "unit-utils.ss" +(require "../utils/utils.ss") +(require (utils unit-utils) mzlib/trace (only-in scheme/unit provide-signature-elements) "signatures.ss" "tc-toplevel.ss" diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 2eb33e21..0bcfc701 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -1,22 +1,18 @@ #lang scheme/base -(require "private/base-env.ss" - "private/base-types.ss" +(require (rename-in "utils/utils.ss" [infer r:infer])) + +(require (private base-env base-types) (for-syntax scheme/base - "private/type-utils.ss" - "private/typechecker.ss" - "private/type-rep.ss" - "private/provide-handling.ss" - "private/type-environments.ss" - "private/tc-utils.ss" - "private/type-name-env.ss" - "private/type-alias-env.ss" - (except-in "private/utils.ss" extend) - (only-in "private/infer-dummy.ss" infer-param) - "private/infer.ss" - "private/type-effect-convenience.ss" - "private/type-contract.ss" + (private type-utils type-contract type-effect-convenience) + (typecheck typechecker provide-handling) + (env type-environments type-name-env type-alias-env) + (r:infer infer) + (utils tc-utils) + (rep type-rep) + (except-in (utils utils) infer extend) + (only-in (r:infer infer-dummy) infer-param) scheme/nest syntax/kerncase scheme/match)) diff --git a/collects/typed-scheme/private/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss similarity index 100% rename from collects/typed-scheme/private/tc-utils.ss rename to collects/typed-scheme/utils/tc-utils.ss diff --git a/collects/typed-scheme/private/utils.ss b/collects/typed-scheme/utils/utils.ss similarity index 86% rename from collects/typed-scheme/private/utils.ss rename to collects/typed-scheme/utils/utils.ss index 80c3f802..ad04ad79 100644 --- a/collects/typed-scheme/private/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -2,6 +2,7 @@ (require (for-syntax scheme/base) mzlib/plt-match + scheme/require-syntax mzlib/struct) (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log @@ -16,7 +17,38 @@ in-list-forever extend debug - in-syntax) + in-syntax + ;; require macros + rep utils typecheck infer env private) + +(define-syntax (define-requirer stx) + (syntax-case stx () + [(_ nm) + #`(... + (define-require-syntax nm + (lambda (stx) + (syntax-case stx () + [(_ id ...) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([(id* ...) (map (lambda (id) (datum->syntax + id + (string->symbol + (string-append + "typed-scheme/" + #,(symbol->string (syntax-e #'nm)) + "/" + (symbol->string (syntax-e id)))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-in id* ...)))]))))])) + + +(define-requirer rep) +(define-requirer infer) +(define-requirer typecheck) +(define-requirer utils) +(define-requirer env) +(define-requirer private) (define-sequence-syntax in-syntax (lambda () #'syntax->list) From 9b7d9450494bd69fa92b5234908791445aabf74c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 10 Sep 2008 14:49:15 -0400 Subject: [PATCH 7/8] Add no-check language original commit: c7b51cfd2d1dece6ac2254f44e278f3c18ee13a7 --- collects/typed-scheme/no-check.ss | 5 +++++ collects/typed-scheme/no-check/lang/reader.ss | 13 +++++++++++++ collects/typed-scheme/typecheck/tc-expr-unit.ss | 3 ++- 3 files changed, 20 insertions(+), 1 deletion(-) create mode 100644 collects/typed-scheme/no-check.ss create mode 100644 collects/typed-scheme/no-check/lang/reader.ss diff --git a/collects/typed-scheme/no-check.ss b/collects/typed-scheme/no-check.ss new file mode 100644 index 00000000..470a7bed --- /dev/null +++ b/collects/typed-scheme/no-check.ss @@ -0,0 +1,5 @@ +#lang scheme/base + +(require "private/prims.ss") +(provide (all-from-out scheme/base) + (all-from-out "private/prims.ss")) \ No newline at end of file diff --git a/collects/typed-scheme/no-check/lang/reader.ss b/collects/typed-scheme/no-check/lang/reader.ss new file mode 100644 index 00000000..c35cbecc --- /dev/null +++ b/collects/typed-scheme/no-check/lang/reader.ss @@ -0,0 +1,13 @@ +#lang scheme/base +(require (prefix-in r: "../../typed-reader.ss") + (only-in syntax/module-reader wrap-read-all)) + +(define (*read in modpath line col pos) + (wrap-read-all 'typed-scheme/no-check in r:read modpath #f line col pos)) + +(define (*read-syntax src in modpath line col pos) + (wrap-read-all + 'typed-scheme/no-check in (lambda (in) (r:read-syntax src in)) + modpath src line col pos)) + +(provide (rename-out [*read read] [*read-syntax read-syntax])) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 7e32c0c7..c61bbd3d 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -95,7 +95,8 @@ ;; typecheck an expression, but throw away the effect ;; tc-expr/t : Expr -> Type (define (tc-expr/t e) (match (tc-expr e) - [(tc-result: t) t])) + [(tc-result: t) t] + [t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))])) (define (tc-expr/check/t e t) (match (tc-expr/check e t) From 2b288b258210be71345c7f8a5b8b32cba010f729 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 11 Sep 2008 09:01:49 -0400 Subject: [PATCH 8/8] Add eof and read-accept-reader. Fix find-mutated-vars original commit: 7cf9b36c1501aa994d29e1bbd61b1785b5e92655 --- collects/typed-scheme/private/base-env.ss | 3 ++- collects/typed-scheme/private/mutated-vars.ss | 13 +++++------ collects/typed-scheme/utils/utils.ss | 22 ++++++++++--------- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 719c25ba..6600a1f7 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -560,7 +560,8 @@ [values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] [call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] - [foo (N #:bar B #f . ->key . B)] + [eof (-val eof)] + [read-accept-reader (-Param B B)] ) (begin-for-syntax diff --git a/collects/typed-scheme/private/mutated-vars.ss b/collects/typed-scheme/private/mutated-vars.ss index 6e7a2c2d..a362bd53 100644 --- a/collects/typed-scheme/private/mutated-vars.ss +++ b/collects/typed-scheme/private/mutated-vars.ss @@ -14,12 +14,11 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(printf "called with ~a~n" (syntax->datum form)) + ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form))) (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) ;; what we care about: set! [(set! v e) (begin - ;(printf "mutated var found: ~a~n" (syntax-e #'v)) (module-identifier-mapping-put! table #'v #t))] [(define-values (var ...) expr) (find-mutated-vars #'expr)] @@ -28,15 +27,13 @@ [(begin0 . rest) (fmv/list #'rest)] [(#%plain-lambda _ . rest) (fmv/list #'rest)] [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))] - [(if e1 e2) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e2))] - [(if e1 e2 e3) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e1) (find-mutated-vars #'e3))] - [(with-continuation-mark e1 e2 e3) (begin (find-mutated-vars #'e1) - (find-mutated-vars #'e1) - (find-mutated-vars #'e3))] + [(if . es) (fmv/list #'es)] + [(with-continuation-mark . es) (fmv/list #'es)] [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) (fmv/list #'b))] [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) - (fmv/list #'b))] + (fmv/list #'b))] + [(#%expression e) (find-mutated-vars #'e)] ;; all the other forms don't have any expression subforms (like #%top) [_ (void)])) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index ad04ad79..6ca8a6a9 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -30,16 +30,18 @@ (syntax-case stx () [(_ id ...) (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([(id* ...) (map (lambda (id) (datum->syntax - id - (string->symbol - (string-append - "typed-scheme/" - #,(symbol->string (syntax-e #'nm)) - "/" - (symbol->string (syntax-e id)))) - id id)) - (syntax->list #'(id ...)))]) + (with-syntax ([(id* ...) + (map (lambda (id) + (datum->syntax + id + (string->symbol + (string-append + "typed-scheme/" + #,(symbol->string (syntax-e #'nm)) + "/" + (symbol->string (syntax-e id)))) + id id)) + (syntax->list #'(id ...)))]) (syntax/loc stx (combine-in id* ...)))]))))]))