diff --git a/collects/tests/typed-scheme/succeed/match-dots2.ss b/collects/tests/typed-scheme/succeed/match-dots2.ss new file mode 100644 index 00000000..d549ba14 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/match-dots2.ss @@ -0,0 +1,9 @@ +#lang typed-scheme + +(require scheme/match) + +(: post-eval : -> Number) +;; evaluates a postfix sequence of items, using a stack +(define (post-eval) + (match '(1 2) + [(list (? number? #{stack : (Listof Number)}) ...) 3])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/find-annotation.ss b/collects/typed-scheme/typecheck/find-annotation.ss index 0f94823f..37ff3576 100644 --- a/collects/typed-scheme/typecheck/find-annotation.ss +++ b/collects/typed-scheme/typecheck/find-annotation.ss @@ -1,9 +1,10 @@ #lang scheme/base (require "../utils/utils.ss" syntax/parse - scheme/contract + scheme/contract scheme/trace (rep type-rep) - (private type-annotation)) + (private type-annotation) + (for-template scheme/base)) (p/c [find-annotation (syntax? identifier? . -> . (or/c #f Type/c))]) @@ -63,3 +64,5 @@ (find #'body))] [e:core-expr (ormap find (syntax->list #'(e.expr ...)))])) + +;(trace find-annotation) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 1896ed0d..c076819b 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -143,17 +143,18 @@ (define (let-loop-check form lp actuals args body expected) (syntax-parse #`(#,args #,body #,actuals) - #:literals (#%plain-app if null?) + #:literals (#%plain-app if null? pair?) [((val acc ...) - ((if (#%plain-app null? val*) thn els)) + ((~and inner-body (if (#%plain-app (~or pair? null?) val*) thn els))) (actual actuals ...)) + #:fail-unless (and (free-identifier=? #'val #'val*) - (ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a)) - (syntax->list #'(acc ...)))) + (ormap (lambda (a) (find-annotation #'inner-body a)) + (syntax->list #'(acc ...)))) #f (let* ([ts1 (generalize (tc-expr/t #'actual))] [ann-ts (for/list ([a (in-syntax #'(acc ...))] [ac (in-syntax #'(actuals ...))]) - (or (find-annotation #'(if (#%plain-app null? val*) thn els) a) + (or (find-annotation #'inner-body a) (generalize (tc-expr/t ac))))] [ts (cons ts1 ann-ts)]) ;; check that the actual arguments are ok here @@ -164,7 +165,7 @@ (tc/rec-lambda/check form args body lp ts expected) expected)] ;; special case when argument needs inference - [_ + [_ (let ([ts (for/list ([ac (syntax->list actuals)] [f (syntax->list args)]) (or diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss index 9f19bd67..70dce20c 100644 --- a/collects/typed-scheme/types/convenience.ss +++ b/collects/typed-scheme/types/convenience.ss @@ -31,6 +31,7 @@ (match t* [(Value: '()) (-lst Univ)] [(Mu: var (Union: (list (Value: '()) (Pair: _ (F: var))))) t*] + [(Pair: t1 (Value: '())) (-lst t1)] [(Pair: t1 t2) (let ([t-new (loop t2)]) (if (type-equal? (-lst t1) t-new)