From 17c0dbbcd3b46cd1f879e9e36fd3f549e6cf1b0b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 20 Apr 2009 22:41:37 +0000 Subject: [PATCH] Infer on ((lambda add types for matchable? and match-equality-test svn: r14570 original commit: 8918328e8a06d4cc7973bd94cb6c436e286d0be1 --- collects/typed-scheme/private/base-env.ss | 4 +++- collects/typed-scheme/typecheck/tc-app-unit.ss | 9 ++++++++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 4fbde9fb..55b5b9ca 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)) [raise (Univ . -> . (Un))] @@ -148,6 +148,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])] diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 63db7660..f3a951e8 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)]))