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

handle full generality of extend-parameterization

Browse Source 
original commit: 4984345657eda9736b458cf73f97996e3da1ce95
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-04 16:52:20 -04:00
parent bbf8fe4b54
commit b45d2f1a0c
1 changed files with 16 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/typed-scheme/typecheck/tc-app.rkt
View File

@ -20,7 +20,7 @@
(r:infer infer)
(for-template
(only-in '#%kernel [apply k:apply])
"internal-forms.ss" scheme/base scheme/bool
"internal-forms.ss" scheme/base scheme/bool '#%paramz
(only-in racket/private/class-internal make-object do-make-object)))
(import tc-expr^ tc-lambda^ tc-dots^ tc-let^)
@ -425,7 +425,21 @@
(syntax-parse form
#:literals (#%plain-app #%plain-lambda letrec-values quote
values apply k:apply not list list* call-with-values do-make-object make-object cons
andmap ormap reverse)
andmap ormap reverse extend-parameterization)
[(#%plain-app extend-parameterization pmz args ...)
(let loop ([args (syntax->list #'(args ...))])
(if (null? args) Univ
(let* ([p (car args)]
[pt (single-value p)]
[v (cadr args)]
[vt (single-value v)])
(match pt
[(tc-result1: (Param: a b))
(check-below vt a)
(loop (cddr args))]
[(tc-result1: t)
(tc-error/expr #:ret (or expected (ret Univ)) "expected Parameter, but got ~a" t)
(loop (cddr args))]))))]
;; call-with-values
[(#%plain-app call-with-values prod con)
(match (tc/funapp #'prod #'() (single-value #'prod) null #f)