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

Simplify typechecking of extend-parameterization.

Browse Source
This commit is contained in:
Eric Dobson 2014-03-20 10:12:04 -07:00
parent c11de94f2a
commit ca867bc97f
1 changed files with 12 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt
View File

@ -5,6 +5,7 @@
"utils.rkt" "utils.rkt"
syntax/parse racket/match syntax/parse racket/match
unstable/list syntax/stx unstable/list syntax/stx
unstable/sequence
(typecheck signatures tc-funapp) (typecheck signatures tc-funapp)
(types abbrev utils) (types abbrev utils)
(private type-annotation) (private type-annotation)
@ -23,20 +24,17 @@
(define-tc/app-syntax-class (tc/app-special expected) (define-tc/app-syntax-class (tc/app-special expected)
#:literal-sets (kernel-literals special-literals) #:literal-sets (kernel-literals special-literals)
;; parameterize ;; parameterize
(pattern (extend-parameterization pmz args ...) (pattern (extend-parameterization pmz (~seq params args) ...)
(let loop ([args (syntax->list #'(args ...))]) (begin
(if (null? args) (ret Univ) (for ([param (in-syntax #'(params ...))]
(let* ([p (car args)] [arg (in-syntax #'(args ...))])
[pt (single-value p)] (match (single-value param)
[v (cadr args)]) [(tc-result1: (Param: a b))
(match pt (tc-expr/check arg (ret a))]
[(tc-result1: (Param: a b)) [(tc-result1: t)
(tc-expr/check v (ret a)) (single-value arg)
(loop (cddr args))] (tc-error/delayed "expected Parameter, but got ~a" t)]))
[(tc-result1: t) (ret Univ)))
(single-value v)
(tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
(loop (cddr args))])))))
;; use the additional but normally ignored first argument to make-sequence ;; use the additional but normally ignored first argument to make-sequence
;; to provide a better instantiation ;; to provide a better instantiation
(pattern ((~var op (id-from 'make-sequence 'racket/private/for)) (pattern ((~var op (id-from 'make-sequence 'racket/private/for))