From 994f0205f49bb8960b118ca0dda8dae740b1ab1c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 24 Apr 2009 21:30:18 +0000 Subject: [PATCH] fix conflicts svn: r14601 --- collects/typed-scheme/env/lexical-env.ss | 6 +++--- collects/typed-scheme/private/base-env.ss | 7 ++++++- collects/typed-scheme/typecheck/tc-app-unit.ss | 15 +++++++++++++-- collects/typed-scheme/typecheck/tc-if-unit.ss | 6 ++++-- 4 files changed, 26 insertions(+), 8 deletions(-) diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 07f8134c09..b61332399a 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -23,7 +23,7 @@ ;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; identifer -> Type -(define (lookup-type/lexical i [env (lexical-env)]) +(define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f]) (lookup env i (lambda (i) (lookup-type i (lambda () @@ -31,7 +31,7 @@ => (lambda (a) (-lst (substitute Univ (cdr a) (car a))))] - [else (lookup-fail i)])))))) + [else ((or fail lookup-fail) i)])))))) ;; refine the type of i in the lexical env ;; (identifier type -> type) identifier -> environment @@ -41,7 +41,7 @@ (define (update f k env) (parameterize ([current-orig-stx k]) - (let* ([v (lookup-type/lexical k)] + (let* ([v (lookup-type/lexical k env #:fail (lambda _ Univ))] [new-v (f k v)] [new-env (extend env k new-v)]) new-env))) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 3b6ce0806f..17e73dbfcf 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -9,7 +9,7 @@ (only-in '#%kernel [apply kernel:apply]) scheme/promise (only-in string-constants/private/only-once maybe-print-message) - (only-in scheme/match/runtime match:error) + (only-in scheme/match/runtime match:error matchable? match-equality-test) (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym]))) [raise (Univ . -> . (Un))] @@ -146,6 +146,8 @@ [(Sym B -Namespace (-> Univ)) Univ])] [match:error (Univ . -> . (Un))] +[match-equality-test (-Param (Univ Univ . -> . Univ) (Univ Univ . -> . Univ))] +[matchable? (make-pred-ty (Un -String -Bytes))] [display (cl-> [(Univ) -Void] [(Univ -Port) -Void])] [write (cl-> [(Univ) -Void] [(Univ -Port) -Void])] [print (cl-> [(Univ) -Void] [(Univ -Port) -Void])] @@ -568,6 +570,9 @@ (cl->* ((-lst a) . -> . (-lst a)) ((-lst a) (a a . -> . Univ) . -> . (-lst a))))] +[append-map + (-polydots (c a b) ((list ((list a) (b b) . ->... . (-lst c)) (-lst a)) + ((-lst b) b) . ->... .(-lst c)))] ;; scheme/tcp [tcp-listener? (make-pred-ty -TCP-Listener)] diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 63db7660b9..e0a64c4c64 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -21,7 +21,7 @@ (only-in scheme/private/class-internal make-object do-make-object))) (require (r:infer constraint-structs)) -(import tc-expr^ tc-lambda^ tc-dots^) +(import tc-expr^ tc-lambda^ tc-dots^ tc-let^) (export tc-app^) ;; comparators that inform the type system @@ -779,6 +779,13 @@ (match-let* ([ft (tc-expr #'f)] [(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) (ret (Un (-val #f) t)))))] + ;; infer for ((lambda + [(#%plain-app (#%plain-lambda (x ...) . body) args ...) + (= (length (syntax->list #'(x ...))) + (length (syntax->list #'(args ...)))) + (tc/let-values/check #'((x) ...) #'(args ...) #'body + #'(let-values ([(x) args] ...) . body) + expected)] ;; default case [(#%plain-app f args ...) (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) @@ -804,7 +811,11 @@ (ret expected))] ;; special case when argument needs inference [_ - (let ([ts (map (compose generalize tc-expr/t) (syntax->list actuals))]) + (let ([ts (for/list ([ac (syntax->list actuals)] + [f (syntax->list args)]) + (or + (type-annotation f #:infer #t) + (generalize (tc-expr/t ac))))]) (tc/rec-lambda/check form args body lp ts expected) (ret expected))])) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss index 24bb6cd2df..3d077cdcde 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -41,7 +41,8 @@ (syntax-rules () [(check-rest f v) (with-update-type/lexical f v (loop (cdr effs)))] - [(check-rest f t v) (check-rest (type-op f t) v)])) + [(check-rest f t v) + (check-rest (type-op f t) v)])) (if (null? effs) ;; base case (let* ([reachable? (not (unbox flag))]) @@ -79,7 +80,8 @@ ;; just replace the type of v with (-val #f) [(Var-False-Effect: v) (check-rest (lambda (_ old) (-val #f)) v)] ;; v cannot have type (-val #f) - [(Var-True-Effect: v) (check-rest *remove (-val #f) v)]))))) + [(Var-True-Effect: v) + (check-rest *remove (-val #f) v)]))))) ;; the main function (define (tc/if-twoarm tst thn els)