Lots more fixes
svn: r14631 original commit: 9853ae1f0f0d7c4791bc2237ab8183f6102ffa50
This commit is contained in:
Sam Tobin-Hochstadt
parent
4495909274
commit
4329ac34db
|
|
@ -62,44 +62,51 @@
|
|||
[#f null]
|
||||
[(cons a b) (cons a (loop b))]
|
||||
[e (list e)])))
|
||||
(for/fold ([ty ty])
|
||||
([inst (in-improper-stx inst)])
|
||||
(cond [(not inst) ty]
|
||||
[(not (or (Poly? ty) (PolyDots? ty)))
|
||||
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)]
|
||||
|
||||
[(and (Poly? ty)
|
||||
(not (= (length (syntax->list inst)) (Poly-n ty))))
|
||||
(match ty
|
||||
[(list ty)
|
||||
(list
|
||||
(for/fold ([ty ty])
|
||||
([inst (in-improper-stx inst)])
|
||||
(cond [(not inst) ty]
|
||||
[(not (or (Poly? ty) (PolyDots? ty)))
|
||||
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)]
|
||||
[(and (Poly? ty)
|
||||
(not (= (length (syntax->list inst)) (Poly-n ty))))
|
||||
(tc-error/expr #:return (Un)
|
||||
"Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
|
||||
ty (Poly-n ty) (length (syntax->list inst)))]
|
||||
[(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty)))))
|
||||
;; we can provide 0 arguments for the ... var
|
||||
(tc-error/expr #:return (Un)
|
||||
"Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a"
|
||||
ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))]
|
||||
[(PolyDots? ty)
|
||||
;; In this case, we need to check the last thing. If it's a dotted var, then we need to
|
||||
;; use instantiate-poly-dotted, otherwise we do the normal thing.
|
||||
(let-values ([(all-but-last last-stx) (split-last (syntax->list inst))])
|
||||
(match (syntax-e last-stx)
|
||||
[(cons last-ty-stx (? identifier? last-id-stx))
|
||||
(unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f)))
|
||||
(tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx)))
|
||||
(if (= (length all-but-last) (sub1 (PolyDots-n ty)))
|
||||
(let* ([last-id (syntax-e last-id-stx)]
|
||||
[last-ty
|
||||
(parameterize ([current-tvars (extend-env (list last-id)
|
||||
(list (make-DottedBoth (make-F last-id)))
|
||||
(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)))])))]
|
||||
[_ (if inst
|
||||
(tc-error/expr #:return (Un)
|
||||
"Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
|
||||
ty (Poly-n ty) (length (syntax->list inst)))]
|
||||
[(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty)))))
|
||||
;; we can provide 0 arguments for the ... var
|
||||
(tc-error/expr #:return (Un)
|
||||
"Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a"
|
||||
ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))]
|
||||
[(PolyDots? ty)
|
||||
;; In this case, we need to check the last thing. If it's a dotted var, then we need to
|
||||
;; use instantiate-poly-dotted, otherwise we do the normal thing.
|
||||
(let-values ([(all-but-last last-stx) (split-last (syntax->list inst))])
|
||||
(match (syntax-e last-stx)
|
||||
[(cons last-ty-stx (? identifier? last-id-stx))
|
||||
(unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f)))
|
||||
(tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx)))
|
||||
(if (= (length all-but-last) (sub1 (PolyDots-n ty)))
|
||||
(let* ([last-id (syntax-e last-id-stx)]
|
||||
[last-ty
|
||||
(parameterize ([current-tvars (extend-env (list last-id)
|
||||
(list (make-DottedBoth (make-F last-id)))
|
||||
(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)))])))
|
||||
"Cannot instantiate expression that produces ~a values"
|
||||
(if (null? ty) 0 "multiple"))
|
||||
ty)]))
|
||||
|
||||
;; typecheck an identifier
|
||||
;; the identifier has variable effect
|
||||
|
|
@ -324,7 +331,7 @@
|
|||
(match ty
|
||||
[(tc-results: ts fs os)
|
||||
(let ([ts* (do-inst form ts)])
|
||||
(ret ts fs os))]))))
|
||||
(ret ts* fs os))]))))
|
||||
|
||||
(define (tc/send rcvr method args [expected #f])
|
||||
(match (tc-expr rcvr)
|
||||
|
|
|
|||
|
|
@ -204,21 +204,6 @@
|
|||
(cons (car bodies) bodies*)
|
||||
(cons (syntax-len (car formals)) nums-seen))]))))
|
||||
|
||||
;; tc/lambda : syntax syntax-list syntax-list -> tc-result
|
||||
(define (tc/lambda form formals bodies)
|
||||
(tc/lambda/internal form formals bodies #f))
|
||||
|
||||
;; 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 (tc/mono-lambda formals bodies expected))))
|
||||
|
||||
;; tc/lambda : syntax syntax-list syntax-list Type -> tc-result
|
||||
(define (tc/lambda/check form formals bodies expected)
|
||||
(tc/lambda/internal form 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)
|
||||
|
|
@ -279,7 +264,21 @@
|
|||
(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)]))
|
||||
|
||||
|
||||
;; 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))))))
|
||||
|
||||
;; tc/lambda : syntax syntax-list syntax-list -> tc-result
|
||||
(define (tc/lambda form formals bodies)
|
||||
(tc/lambda/internal form formals bodies #f))
|
||||
|
||||
;; tc/lambda/check : syntax syntax-list syntax-list Type -> tc-result
|
||||
(define (tc/lambda/check form formals bodies expected)
|
||||
(tc/lambda/internal form formals bodies expected))
|
||||
|
||||
;; form : a syntax object for error reporting
|
||||
;; formals : the formal arguments to the loop
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
(require (private base-types)
|
||||
(for-syntax
|
||||
(except-in stxclass id)
|
||||
scheme/base
|
||||
(private type-contract)
|
||||
(types utils convenience)
|
||||
|
|
@ -117,28 +118,28 @@
|
|||
[expanded-module-stx body2])]
|
||||
;; typecheck the body, and produce syntax-time code that registers types
|
||||
[let ([type (tc-toplevel-form body2)])])
|
||||
(kernel-syntax-case body2 #f
|
||||
[(head . _)
|
||||
(or (free-identifier=? #'head #'define-values)
|
||||
(free-identifier=? #'head #'define-syntaxes)
|
||||
(free-identifier=? #'head #'require)
|
||||
(free-identifier=? #'head #'provide)
|
||||
(free-identifier=? #'head #'begin)
|
||||
(void? type)
|
||||
(type-equal? -Void (tc-result-t type)))
|
||||
(define-syntax-class invis-kw
|
||||
#:literals (define-values define-syntaxes require provide begin)
|
||||
(pattern define-values)
|
||||
(pattern define-syntaxes)
|
||||
(pattern require)
|
||||
(pattern provide)
|
||||
(pattern begin))
|
||||
(syntax-parse body2
|
||||
[(head:invis-kw . _)
|
||||
body2]
|
||||
;; construct code to print the type
|
||||
[_
|
||||
(nest
|
||||
([with-syntax ([b body2]
|
||||
[ty-str (match type
|
||||
[(tc-result: t)
|
||||
(format "- : ~a\n" t)]
|
||||
[x (int-err "bad type result: ~a" x)])])])
|
||||
#`(let ([v b] [type 'ty-str])
|
||||
(begin0
|
||||
v
|
||||
(printf type))))]))]))
|
||||
[_ (let ([ty-str (match type
|
||||
[(tc-result1: t)
|
||||
(if (type-equal? t -Void)
|
||||
#f
|
||||
(format "- : ~a\n" t))]
|
||||
[x (int-err "bad type result: ~a" x)])])
|
||||
(if #'ty-str
|
||||
#`(let ([v #,body2] [type '#,ty-str])
|
||||
(begin0
|
||||
v
|
||||
(printf type)))
|
||||
body2))]))]))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -158,8 +158,8 @@
|
|||
#:rest [rest #f] #:drest [drest #f] #:kws [kws null]
|
||||
#:filters [filters -no-lfilter] #:object [obj -no-lobj])
|
||||
(c:->* ((listof Type/c) (or/c Values? ValuesDots? Type/c))
|
||||
(#:rest Type/c
|
||||
#:drest (cons/c Type/c symbol?)
|
||||
(#:rest (or/c #f Type/c)
|
||||
#:drest (or/c #f (cons/c Type/c symbol?))
|
||||
#:kws (listof Keyword?)
|
||||
#:filters LFilterSet?
|
||||
#:object LatentObject?)
|
||||
|
|
|
|||
|
|
@ -141,7 +141,8 @@
|
|||
[(Box: e) (fp "(Box ~a)" e)]
|
||||
[(Union: elems) (fp "~a" (cons 'U elems))]
|
||||
[(Pair: l r) (fp "(Pair ~a ~a)" l r)]
|
||||
[(F: nm) (fp "~a" nm)]
|
||||
[(F: nm) (fp "~a" nm)]
|
||||
[(Values: (list v)) (fp "~a" v)]
|
||||
[(Values: (list v ...)) (fp "~a" (cons 'values v))]
|
||||
[(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))]
|
||||
[(Param: in out)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user