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

fixes for plambda

Browse Source 
svn: r14634
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-27 22:44:42 +00:00
parent dfbfc371e2
commit 2e2e9b8acf
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 (car bodies) bodies*)
(cons (syntax-len (car formals)) nums-seen))])))) (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 ;; 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) (define (tc/plambda form formals bodies expected)
(define (maybe-loop form formals bodies expected) (define (maybe-loop form formals bodies expected)
(match expected (match expected
[(Function: _) (tc/mono-lambda formals bodies expected)] [(Function: _) (tc/mono-lambda/type formals bodies expected)]
[(or (Poly: _ _) (PolyDots: _ _)) [(or (Poly: _ _) (PolyDots: _ _))
(tc/plambda form formals bodies expected)])) (tc/plambda form formals bodies expected)]))
(match expected (match expected
@ -224,7 +227,7 @@
[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 expected*))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
(ret expected))] expected)]
[(PolyDots-names: (list ns ... dvar) expected*) [(PolyDots-names: (list ns ... dvar) expected*)
(let-values (let-values
([(tvars dotted) ([(tvars dotted)
@ -242,7 +245,7 @@
new-tvars) new-tvars)
(current-tvars))]) (current-tvars))])
(maybe-loop form formals bodies expected*))]) (maybe-loop form formals bodies expected*))])
(ret expected)))] expected))]
[#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 '...)
@ -251,26 +254,26 @@
[ty (parameterize ([current-tvars (extend-env (cons dotted-var literal-tvars) [ty (parameterize ([current-tvars (extend-env (cons dotted-var literal-tvars)
(cons (make-Dotted (make-F dotted-var)) new-tvars) (cons (make-Dotted (make-F dotted-var)) new-tvars)
(current-tvars))]) (current-tvars))])
(tc/mono-lambda formals bodies #f))]) (tc/mono-lambda/type formals bodies #f))])
(ret (make-PolyDots (append literal-tvars (list dotted-var)) ty)))] (make-PolyDots (append literal-tvars (list dotted-var)) ty))]
[tvars [tvars
(let* ([literal-tvars tvars] (let* ([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))])
(tc/mono-lambda formals bodies #f))]) (tc/mono-lambda/type formals bodies #f))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) ;(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) (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)) (tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected))
(ret expected)])) expected]))
;; 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) (Poly? expected) (PolyDots? expected))
(tc/plambda form formals bodies expected) (ret (tc/plambda form formals bodies expected))
(ret (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected)))))) (ret (tc/mono-lambda/type formals bodies expected))))
;; tc/lambda : syntax syntax-list syntax-list -> tc-result ;; tc/lambda : syntax syntax-list syntax-list -> tc-result
(define (tc/lambda form formals bodies) (define (tc/lambda form formals bodies)