diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index dd4edaa5..9dbc9eab 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -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) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index c6dbd984..5a614069 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -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 diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index d6bb00ec..5a43f819 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -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))]))])) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 07e03627..165dbb6c 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -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?) diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 6d919bf6..fee5aa45 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -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)