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

Handle multiple instantiation of a single expression.

Browse Source 
svn: r12148
This commit is contained in:
Sam Tobin-Hochstadt 2008-10-27 20:06:31 +00:00
parent d60ae208e1
commit 0c44c5ce40
1 changed files with 44 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -52,42 +52,50 @@
(define (split-last l) (define (split-last l)
(let-values ([(all-but last-list) (split-at l (sub1 (length l)))]) (let-values ([(all-but last-list) (split-at l (sub1 (length l)))])
(values all-but (car last-list)))) (values all-but (car last-list))))
(cond [(not inst) ty] (define (in-improper-stx stx)
[(not (or (Poly? ty) (PolyDots? ty))) (let loop ([l stx])
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)] (match l
[#f null]
[(and (Poly? ty) [(cons a b) (cons a (loop b))]
(not (= (length (syntax->list inst)) (Poly-n ty)))) [e (list e)])))
(tc-error/expr #:return (Un) (for/fold ([ty ty])
"Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" ([inst (in-improper-stx inst)])
ty (Poly-n ty) (length (syntax->list inst)))] (cond [(not inst) ty]
[(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty))))) [(not (or (Poly? ty) (PolyDots? ty)))
;; we can provide 0 arguments for the ... var (tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)]
(tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a" [(and (Poly? ty)
ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))] (not (= (length (syntax->list inst)) (Poly-n ty))))
[(PolyDots? ty) (tc-error/expr #:return (Un)
;; In this case, we need to check the last thing. If it's a dotted var, then we need to "Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
;; use instantiate-poly-dotted, otherwise we do the normal thing. ty (Poly-n ty) (length (syntax->list inst)))]
(let-values ([(all-but-last last-stx) (split-last (syntax->list inst))]) [(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty)))))
(match (syntax-e last-stx) ;; we can provide 0 arguments for the ... var
[(cons last-ty-stx (? identifier? last-id-stx)) (tc-error/expr #:return (Un)
(unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f))) "Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a"
(tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx))) ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))]
(if (= (length all-but-last) (sub1 (PolyDots-n ty))) [(PolyDots? ty)
(let* ([last-id (syntax-e last-id-stx)] ;; In this case, we need to check the last thing. If it's a dotted var, then we need to
[last-ty ;; use instantiate-poly-dotted, otherwise we do the normal thing.
(parameterize ([current-tvars (extend-env (list last-id) (let-values ([(all-but-last last-stx) (split-last (syntax->list inst))])
(list (make-DottedBoth (make-F last-id))) (match (syntax-e last-stx)
(current-tvars))]) [(cons last-ty-stx (? identifier? last-id-stx))
(parse-type last-ty-stx))]) (unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f)))
(instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id)) (tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx)))
(tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" (if (= (length all-but-last) (sub1 (PolyDots-n ty)))
ty (sub1 (PolyDots-n ty)) (length all-but-last)))] (let* ([last-id (syntax-e last-id-stx)]
[_ [last-ty
(instantiate-poly ty (map parse-type (syntax->list inst)))]))] (parameterize ([current-tvars (extend-env (list last-id)
[else (list (make-DottedBoth (make-F last-id)))
(instantiate-poly ty (map parse-type (syntax->list inst)))])) (current-tvars))])
(parse-type last-ty-stx))])
(instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id))
(tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
ty (sub1 (PolyDots-n ty)) (length all-but-last)))]
[_
(instantiate-poly ty (map parse-type (syntax->list inst)))]))]
[else
(instantiate-poly ty (map parse-type (syntax->list inst)))])))
;; typecheck an identifier ;; typecheck an identifier
;; the identifier has variable effect ;; the identifier has variable effect