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

fixes for plambda

Browse Source 
svn: r14634

original commit: 2e2e9b8acf4cb8e48327f4f29229577bee19a006
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-27 22:44:42 +00:00
parent 7b651a3856
commit b0634cd6af
2 changed files with 25 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/typed-scheme/test.ss Normal file
View File

@ -0,0 +1,11 @@
#lang typed-scheme
(define: x : (U Number #f) 1)
(if x #{x :: Number} 1)
(lambda () 1)
(lambda: ([y : Number]) (if #t y y))
(plambda: (a) ([y : Number]) (if y #t #f))
(plambda: (a) ([y : a]) y)
(plambda: (a) ([y : a]) y)
(plambda: () ([y : Boolean]) (if y #t #f))

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

@ -204,12 +204,15 @@
(cons (car bodies) bodies*)
(cons (syntax-len (car formals)) nums-seen))]))))
(define (tc/mono-lambda/type formals bodies expected)
(make-Function (map lam-result->type (tc/mono-lambda formals bodies expected))))
;; tc/plambda syntax syntax-list syntax-list type -> Poly
;; formals and bodies must by syntax-lists
(define (tc/plambda form formals bodies expected)
(define (maybe-loop form formals bodies expected)
(match expected
[(Function: _) (tc/mono-lambda formals bodies expected)]
[(Function: _) (tc/mono-lambda/type formals bodies expected)]
[(or (Poly: _ _) (PolyDots: _ _))
(tc/plambda form formals bodies expected)]))
(match expected
@ -224,7 +227,7 @@
[ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
(maybe-loop form formals bodies expected*))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
(ret expected))]
expected)]
[(PolyDots-names: (list ns ... dvar) expected*)
(let-values
([(tvars dotted)
@ -242,7 +245,7 @@
new-tvars)
(current-tvars))])
(maybe-loop form formals bodies expected*))])
(ret expected)))]
expected))]
[#f
(match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda)))
[(list tvars ... dotted-var '...)
@ -251,26 +254,26 @@
[ty (parameterize ([current-tvars (extend-env (cons dotted-var literal-tvars)
(cons (make-Dotted (make-F dotted-var)) new-tvars)
(current-tvars))])
(tc/mono-lambda formals bodies #f))])
(ret (make-PolyDots (append literal-tvars (list dotted-var)) ty)))]
(tc/mono-lambda/type formals bodies #f))])
(make-PolyDots (append literal-tvars (list dotted-var)) ty))]
[tvars
(let* ([literal-tvars tvars]
[new-tvars (map make-F literal-tvars)]
[ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
(tc/mono-lambda formals bodies #f))])
(tc/mono-lambda/type formals bodies #f))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
(ret (make-Poly literal-tvars ty)))])]
(make-Poly literal-tvars ty))])]
[_
(unless (check-below (tc/plambda form formals bodies #f) expected)
(tc-error/expr #:return (ret expected) "Expected a value of type ~a, but got a polymorphic function." expected))
(ret expected)]))
(tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected))
expected]))
;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic
;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result
(define (tc/lambda/internal form formals bodies expected)
(if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected))
(tc/plambda form formals bodies expected)
(ret (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected))))))
(ret (tc/plambda form formals bodies expected))
(ret (tc/mono-lambda/type formals bodies expected))))
;; tc/lambda : syntax syntax-list syntax-list -> tc-result
(define (tc/lambda form formals bodies)