suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add some contracts in tc/plambda.

Browse Source 
Fix handling of tc-results vs types.

svn: r14812
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-14 15:11:33 +00:00
parent d8c613494e
commit 775fa34f5f
1 changed files with 16 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/typed-scheme/typecheck/tc-lambda-unit.ss
View File

@ -214,14 +214,16 @@
;; tc/plambda syntax syntax-list syntax-list type -> Poly ;; tc/plambda syntax syntax-list syntax-list type -> Poly
;; formals and bodies must by syntax-lists ;; formals and bodies must by syntax-lists
(define (tc/plambda form formals bodies expected) (d/c (tc/plambda form formals bodies expected)
(define (maybe-loop form formals bodies expected) (syntax? syntax? syntax? (or/c tc-results? #f) . --> . Type/c)
(d/c (maybe-loop form formals bodies expected)
(syntax? syntax? syntax? tc-results? . --> . Type/c)
(match expected (match expected
[(Function: _) (tc/mono-lambda/type formals bodies expected)] [(tc-result1: (Function: _)) (tc/mono-lambda/type formals bodies expected)]
[(or (Poly: _ _) (PolyDots: _ _)) [(tc-result1: (or (Poly: _ _) (PolyDots: _ _)))
(tc/plambda form formals bodies expected)])) (tc/plambda form formals bodies expected)]))
(match expected (match expected
[(Poly-names: ns expected*) [(tc-result1: (and t (Poly-names: ns expected*)))
(let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)]) (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)])
(when (and (pair? p) (eq? '... (car (last p)))) (when (and (pair? p) (eq? '... (car (last p))))
(tc-error "Expected a polymorphic function without ..., but given function had ...")) (tc-error "Expected a polymorphic function without ..., but given function had ..."))
@ -230,10 +232,10 @@
[literal-tvars tvars] [literal-tvars tvars]
[new-tvars (map make-F literal-tvars)] [new-tvars (map make-F literal-tvars)]
[ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
(maybe-loop form formals bodies expected*))]) (maybe-loop form formals bodies (ret expected*)))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
expected)] t)]
[(PolyDots-names: (list ns ... dvar) expected*) [(tc-result1: (and t (PolyDots-names: (list ns ... dvar) expected*)))
(let-values (let-values
([(tvars dotted) ([(tvars dotted)
(let ([p (syntax-property form 'typechecker:plambda)]) (let ([p (syntax-property form 'typechecker:plambda)])
@ -249,8 +251,8 @@
(cons (make-Dotted (make-F dotted)) (cons (make-Dotted (make-F dotted))
new-tvars) new-tvars)
(current-tvars))]) (current-tvars))])
(maybe-loop form formals bodies expected*))]) (maybe-loop form formals bodies (ret expected*)))])
expected))] t))]
[#f [#f
(match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda))) (match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda)))
[(list tvars ... dotted-var '...) [(list tvars ... dotted-var '...)
@ -276,7 +278,10 @@
;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic ;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic
;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result ;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result
(define (tc/lambda/internal form formals bodies expected) (define (tc/lambda/internal form formals bodies expected)
(if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected)) (if (or (syntax-property form 'typechecker:plambda)
(match expected
[(tc-result1: t) (or (Poly? t) (PolyDots? t))]
[_ #f]))
(ret (tc/plambda form formals bodies expected) true-filter) (ret (tc/plambda form formals bodies expected) true-filter)
(ret (tc/mono-lambda/type formals bodies expected) true-filter))) (ret (tc/mono-lambda/type formals bodies expected) true-filter)))