From 17c0dbbcd3b46cd1f879e9e36fd3f549e6cf1b0b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 20 Apr 2009 22:41:37 +0000 Subject: [PATCH 1/5] 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)])) From a6b5a432c02c2e96cea3cca4142285eb40551178 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Apr 2009 15:35:05 +0000 Subject: [PATCH 2/5] Add test for match improvements. Improve handling of inference for let loop. svn: r14573 original commit: b1b5fe481681aef76c06b8abf1abe4cc267533ec --- collects/tests/typed-scheme/succeed/for-lists.ss | 6 ++++++ collects/tests/typed-scheme/succeed/match-tests.ss | 9 +++++++++ collects/typed-scheme/typecheck/tc-app-unit.ss | 7 ++++++- 3 files changed, 21 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/succeed/for-lists.ss create mode 100644 collects/tests/typed-scheme/succeed/match-tests.ss diff --git a/collects/tests/typed-scheme/succeed/for-lists.ss b/collects/tests/typed-scheme/succeed/for-lists.ss new file mode 100644 index 00000000..2cd02058 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/for-lists.ss @@ -0,0 +1,6 @@ +#lang typed-scheme + +(: f ((Listof Number) -> (Listof Number))) +(define (f x) + (for/lists (#{y : (Listof Number)}) ([e (in-list x)]) + e)) diff --git a/collects/tests/typed-scheme/succeed/match-tests.ss b/collects/tests/typed-scheme/succeed/match-tests.ss new file mode 100644 index 00000000..3686d07c --- /dev/null +++ b/collects/tests/typed-scheme/succeed/match-tests.ss @@ -0,0 +1,9 @@ +#lang typed-scheme + +(require scheme/match) + +(match "abc" + [(regexp "^abc") 1]) + +(match (list 1 1) + [(list x x) 1]) diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index f3a951e8..698e3c9c 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -811,7 +811,12 @@ (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))))]) + (printf "case 2 ~a~n" ts) (tc/rec-lambda/check form args body lp ts expected) (ret expected))])) From a5c24172b84559f2570ddbf06e219735e76a5e14 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Apr 2009 16:13:00 +0000 Subject: [PATCH 3/5] Fix handling of filters that refer to out-of-scope vars svn: r14574 original commit: 60325b670c25276dddcf904b801bbde922ca2302 --- .../typed-scheme/unit-tests/typecheck-tests.ss | 18 +++++++++--------- collects/typed-scheme/env/lexical-env.ss | 6 +++--- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index ee5a483b..ff39c7f1 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -87,7 +87,7 @@ (+ 1 (car x)) 5)) N] - + (tc-e (if (let ([y 12]) y) 3 4) -Integer) (tc-e 3 -Integer) (tc-e "foo" -String) (tc-e (+ 3 4) -Integer) @@ -496,10 +496,10 @@ [tc-e (raise-type-error 'foo "bar" 7 (list 5)) (Un)] #;[tc-e - (let ((x '(1 3 5 7 9))) - (do: : Number ((x : (list-of Number) x (cdr x)) - (sum : Number 0 (+ sum (car x)))) - ((null? x) sum))) + (let ((x '(1 3 5 7 9))) + (do: : Number ((x : (list-of Number) x (cdr x)) + (sum : Number 0 (+ sum (car x)))) + ((null? x) sum))) N] @@ -541,10 +541,10 @@ [tc-e `(4 ,@'(3)) (-pair N (-lst N))] [tc-e - (let ((x '(1 3 5 7 9))) - (do: : Number ((x : (Listof Number) x (cdr x)) - (sum : Number 0 (+ sum (car x)))) - ((null? x) sum))) + (let ((x '(1 3 5 7 9))) + (do: : Number ((x : (Listof Number) x (cdr x)) + (sum : Number 0 (+ sum (car x)))) + ((null? x) sum))) N] [tc-e (if #f 1 'foo) (-val 'foo)] diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 9ade4f0a..659cd8b8 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -25,7 +25,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) +(define (lookup-type/lexical i [fail #f]) (lookup (lexical-env) i (lambda (i) (lookup-type i (lambda () @@ -33,7 +33,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 @@ -43,7 +43,7 @@ (define (update f k env) (parameterize ([current-orig-stx k]) - (let* ([v (lookup-type/lexical k)] + (let* ([v (lookup-type/lexical k (lambda _ Univ))] [new-v (f k v)] [new-env (extend env k new-v)]) new-env))) From 4d2d5bfc9fe69c51cd687f69a3e59552c7edf388 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Apr 2009 17:43:33 +0000 Subject: [PATCH 4/5] remove debug printf svn: r14578 original commit: 1edd4770f4f73daf82601a20d9e4c44854fee261 --- collects/typed-scheme/typecheck/tc-app-unit.ss | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 698e3c9c..e0a64c4c 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -816,7 +816,6 @@ (or (type-annotation f #:infer #t) (generalize (tc-expr/t ac))))]) - (printf "case 2 ~a~n" ts) (tc/rec-lambda/check form args body lp ts expected) (ret expected))])) From 93291d7e72d894dcc0611c0b570b3158733ff651 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Apr 2009 22:51:55 +0000 Subject: [PATCH 5/5] type for append-map svn: r14579 original commit: 062008c7586ec2192d1a3b51f6a27402a8e7efb9 --- collects/typed-scheme/private/base-env.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 55b5b9ca..b6e34edf 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -571,6 +571,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)]