diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss index fbabde26f3..a88b883f57 100644 --- a/collects/typed-scheme/private/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -91,19 +91,30 @@ (let loop ([args arg-types] [doms dom-types] [stxs arg-stxs] [arg-count 1]) (cond [(and (null? args) (null? doms)) (values null null)] ;; here, we just return the empty effect - [(null? args) (tc-error "Insufficient arguments to function application, expected ~a, got ~a" - (length dom-types) (length arg-types))] + [(null? args) + (tc-error/delayed + "Insufficient arguments to function application, expected ~a, got ~a" + (length dom-types) (length arg-types)) + (values null null)] [(and (null? doms) rest-type) (if (subtype (car args) rest-type) (loop (cdr args) doms (cdr stxs) (add1 arg-count)) - (tc-error/stx (car stxs) "Rest argument had wrong type, expected: ~a and got: ~a" rest-type (car args)))] + (begin + (tc-error/delayed #:stx (car stxs) + "Rest argument had wrong type, expected: ~a and got: ~a" + rest-type (car args)) + (values null null)))] [(null? doms) - (tc-error "Too many arguments to function, expected ~a, got ~a" (length dom-types) (length arg-types))] + (tc-error/delayed "Too many arguments to function, expected ~a, got ~a" (length dom-types) (length arg-types)) + (values null null)] [(subtype (car args) (car doms)) (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))] [else - (tc-error/stx (car stxs) "Wrong function argument type, expected ~a, got ~a for argument ~a" - (car doms) (car args) arg-count)])))) + (tc-error/delayed + #:stx (car stxs) + "Wrong function argument type, expected ~a, got ~a for argument ~a" + (car doms) (car args) arg-count) + (values null null)])))) ;(trace tc-args) @@ -125,12 +136,15 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests]) (cond [(null? doms*) (if (and (not (null? doms)) (null? (cdr doms))) - (tc-error + (tc-error/expr + #:return (ret (Un)) "bad arguments to apply - function expected ~a fixed arguments and (Listof ~a) rest argument, given ~a" (car doms) (car rests) arg-tys0) - (tc-error "no function domain matched - domains were: ~a arguments were ~a" - (map printable doms rests) - arg-tys0))] + (tc-error/expr + #:return (ret (Un)) + "no function domain matched - domains were: ~a arguments were ~a" + (map printable doms rests) + arg-tys0))] [(and (subtypes arg-tys (car doms*)) (car rests*) (subtype tail-ty (make-Listof (car rests*)))) (ret (car rngs*))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))] @@ -141,9 +155,14 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests]) (cond [(null? doms*) (if (= 1 (length doms)) - (tc-error "polymorphic function domain did not match - domain was: ~a arguments were ~a" - (car doms) arg-tys0) - (tc-error "no polymorphic function domain matched - domains were: ~a arguments were ~a" doms arg-tys0))] + (tc-error/expr + #:return (ret (Un)) + "polymorphic function domain did not match - domain was: ~a arguments were ~a" + (car doms) arg-tys0) + (tc-error/expr + #:return (ret (Un)) + "no polymorphic function domain matched - domains were: ~a arguments were ~a" + doms arg-tys0))] [(and (= (length (car doms*)) (length arg-tys)) (infer/list (append (car doms*) (list (make-Listof (car rests*)))) arg-tys0 vars)) @@ -155,8 +174,10 @@ (ret (subst-all substitution (car rngs*))))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))] [(tc-result: (Poly: vars (Function: '()))) - (tc-error "Function has no cases")] - [f-ty (tc-error "Type of argument to apply is not a function type: ~n~a" f-ty)])))) + (tc-error/expr #:return (ret (Un)) + "Function has no cases")] + [f-ty (tc-error/expr #:return (ret (Un)) + "Type of argument to apply is not a function type: ~n~a" f-ty)])))) (define (stringify l [between " "]) (define (intersperse v l) @@ -187,8 +208,11 @@ [(list t) (if (subtype t in) (ret -Void) - (tc-error "Wrong argument to parameter - expected ~a and got ~a" in t))] - [_ (tc-error "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtypes))])] + (tc-error/expr #:return (ret (Un)) + "Wrong argument to parameter - expected ~a and got ~a" in t))] + [_ (tc-error/expr #:return (ret (Un)) + "Wrong number of arguments to parameter - expected 0 or 1, got ~a" + (length argtypes))])] [(tc-result: (Function: (list (arr: doms rngs rests latent-thn-effs latent-els-effs) ..1)) thn-eff els-eff) (if (= 1 (length doms)) (let-values ([(thn-eff els-eff) @@ -201,7 +225,9 @@ (ret (car rngs) eff))) (let loop ([doms* doms] [rngs rngs] [rests rests]) (cond [(null? doms*) - (tc-error "no function domain matched - domains were: ~a arguments were ~a" doms argtypes)] + (tc-error/expr + #:return (ret (Un)) + "no function domain matched - domains were: ~a arguments were ~a" doms argtypes)] [(subtypes/varargs argtypes (car doms*) (car rests)) (ret (car rngs))] [else (loop (cdr doms*) (cdr rngs) (cdr rests))])))] [(and rft (tc-result: (Poly: vars (Function: (list (arr: doms rngs #f thn-effs els-effs) ...))))) @@ -217,10 +243,12 @@ (cond [(null? doms*) (match-let ([(tc-result: (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs #f _ _) ...)))) ftype]) (if (= 1 (length doms)) - (tc-error "Polymorphic function could not be applied to arguments:~nExpected: ~a ~nActual: ~a" - (car msg-doms) argtypes) - (tc-error "no polymorphic function domain matched - possible domains were: ~n~a~narguments: were ~n~a" - (stringify (map stringify msg-doms) "\n") (stringify argtypes))))] + (tc-error/expr #:return (ret (Un)) + "Polymorphic function could not be applied to arguments:~nExpected: ~a ~nActual: ~a" + (car msg-doms) argtypes) + (tc-error/expr #:return (ret (Un)) + "no polymorphic function domain matched - possible domains were: ~n~a~narguments: were ~n~a" + (stringify (map stringify msg-doms) "\n") (stringify argtypes))))] [(and (= (length (car doms*)) (length argtypes)) (infer/list (car doms*) argtypes vars)) @@ -257,16 +285,17 @@ (unless (subtypes/varargs argtypes new-dom new-rest) (int-err "Inconsistent substitution - arguments not subtypes")) (ret (subst-all substitution rng))) - (tc-error "no polymorphic function domain matched - domain was: ~a rest type was: ~a arguments were ~a" - (stringify dom) rest (stringify argtypes))))] + (tc-error/expr #:return (ret (Un)) + "no polymorphic function domain matched - domain was: ~a rest type was: ~a arguments were ~a" + (stringify dom) rest (stringify argtypes))))] [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests thn-effs els-effs) ...)))) - (tc-error "polymorphic vararg case-lambda application not yet supported")] + (tc-error/expr #:return (ret (Un)) "polymorphic vararg case-lambda application not yet supported")] ;; Union of function types works if we can apply all of them [(tc-result: (Union: (list (and fs (Function: _)) ...)) e1 e2) (match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop (ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)]) (ret (apply Un ts)))] - [(tc-result: f-ty _ _) (tc-error "Cannot apply expression of type ~a, since it is not a function type" f-ty)])))) + [(tc-result: f-ty _ _) (tc-error #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" f-ty)])))) ;(trace tc/funapp) diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/private/tc-expr-unit.ss index 637c419326..0a61bfad49 100644 --- a/collects/typed-scheme/private/tc-expr-unit.ss +++ b/collects/typed-scheme/private/tc-expr-unit.ss @@ -60,7 +60,7 @@ [(byte-pregexp? v) -Byte-PRegexp] [(byte-regexp? v) -Byte-Regexp] [(regexp? v) -Regexp] - [else (begin (printf "checking literal : ~a~n" v) Univ)])) + [else Univ])) ;; typecheck an identifier ;; the identifier has variable effect @@ -68,19 +68,21 @@ (define (tc-id id) (let* ([ty (lookup-type/lexical id)] [inst (syntax-property id 'type-inst)]) - (when (and inst - (not (Poly? ty))) - (tc-error "Cannot instantiate non-polymorphic type ~a" ty)) - (when (and inst + (cond [(and inst + (not (Poly? ty))) + (tc-error/expr #:return (ret (Un)) "Cannot instantiate non-polymorphic type ~a" ty)] + [(and inst (not (= (length (syntax->list inst)) (Poly-n ty)))) - (tc-error "Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" - ty (Poly-n ty) (length (syntax->list inst)))) - (let ([ty* (if inst - (begin - (printf/log "Type Instantiation: ~a~n" (syntax-e id)) - (instantiate-poly ty (map parse-type (syntax->list inst)))) - ty)]) - (ret ty* (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id)))))) + (tc-error/expr #:return (ret (Un)) + "Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" + ty (Poly-n ty) (length (syntax->list inst)))] + [else + (let ([ty* (if inst + (begin + (printf/log "Type Instantiation: ~a~n" (syntax-e id)) + (instantiate-poly ty (map parse-type (syntax->list inst)))) + ty)]) + (ret ty* (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id))))]))) ;; typecheck an expression, but throw away the effect ;; tc-expr/t : Expr -> Type @@ -91,13 +93,12 @@ (match (list tr1 expected) [(list (tc-result: t1 te1 ee1) t2) (unless (subtype t1 t2) - (tc-error "Expected ~a, but got ~a" t2 t1)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) (ret expected)] [(list t1 t2) (unless (subtype t1 t2) - (tc-error "Expected ~a, but got ~a" t2 t1)) - (ret expected)] - [_ (error "bad arguments to check-below")])) + (tc-error/expr"Expected ~a, but got ~a" t2 t1)) + (ret expected)])) (define (tc-expr/check form expected) (parameterize ([current-orig-stx form]) @@ -120,7 +121,7 @@ (syntax-property form 'typechecker:ignore-some) (let ([ty (check-subforms/ignore form)]) (unless ty - (tc-error "internal error: ignore-some")) + (int-err "internal error: ignore-some")) (check-below ty expected))] ;; data [(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))] @@ -133,13 +134,13 @@ (match-let* ([(tc-result: id-t) (tc-id #'id)] [(tc-result: val-t) (tc-expr #'val)]) (unless (subtype val-t id-t) - (tc-error "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t)) + (tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t)) (ret -Void))] ;; top-level variable reference - occurs at top level [(#%top . id) (check-below (tc-id #'id) expected)] ;; weird [(#%variable-reference . _) - (tc-error "#%variable-reference is not supported by Typed Scheme")] + (tc-error/expr #:return (ret expected) "#%variable-reference is not supported by Typed Scheme")] ;; identifiers [x (identifier? #'x) (check-below (tc-id #'x) expected)] ;; w-c-m @@ -179,7 +180,7 @@ [(letrec-values ([(name ...) expr] ...) . body) (tc/letrec-values/check #'((name ...) ...) #'(expr ...) #'body form expected)] ;; other - [_ (tc-error "cannot typecheck unknown form : ~a~n" (syntax->datum form))] + [_ (tc-error/expr #:return (ret expected) "cannot typecheck unknown form : ~a~n" (syntax->datum form))] )))) ;; type check form in the current type environment @@ -197,13 +198,13 @@ (syntax-property form 'typechecker:with-handlers) (let ([ty (check-subforms/with-handlers form)]) (unless ty - (tc-error "internal error: with-handlers")) + (int-err "internal error: with-handlers")) ty)] [stx (syntax-property form 'typechecker:ignore-some) (let ([ty (check-subforms/ignore form)]) (unless ty - (tc-error "internal error: ignore-some")) + (int-err "internal error: ignore-some")) ty)] ;; data @@ -238,7 +239,7 @@ (match-let* ([(tc-result: id-t) (tc-id #'id)] [(tc-result: val-t) (tc-expr #'val)]) (unless (subtype val-t id-t) - (tc-error "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t)) + (tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t)) (ret -Void))] ;; top-level variable reference - occurs at top level [(#%top . id) (tc-id #'id)] @@ -246,7 +247,7 @@ [(#%expression e) (tc-expr #'e)] ;; weird [(#%variable-reference . _) - (tc-error "do not use #%variable-reference")] + (tc-error/expr #:return (ret (Un)) "#%variable-reference is not supported by Typed Scheme")] ;; identifiers [x (identifier? #'x) (tc-id #'x)] ;; application @@ -268,7 +269,7 @@ (begin (tc-exprs (syntax->list #'es)) (tc-expr #'e))] ;; other - [_ (tc-error "cannot typecheck unknown form : ~a~n" (syntax->datum form))])) + [_ (tc-error/expr #:return (ret (Un)) "cannot typecheck unknown form : ~a~n" (syntax->datum form))])) (parameterize ([current-orig-stx form]) ;(printf "form: ~a~n" (syntax->datum form)) @@ -287,13 +288,13 @@ (match (tc-expr method) [(tc-result: (Value: (? symbol? s))) (let* ([ftype (cond [(assq s methods) => cadr] - [else (tc-error "send: method ~a not understood by class ~a" s c)])] + [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] [ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)))]) (if expected (begin (check-below ret-ty expected) (ret expected)) ret-ty))] - [(tc-result: t) (int-err "non-symbol methods not yet supported: ~a" t)])] - [(tc-result: t) (tc-error "send: expected a class instance, got ~a" t)])) + [(tc-result: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])] + [(tc-result: t) (tc-error/expr #:return (or expected (Un)) "send: expected a class instance, got ~a" t)])) ;; type-check a list of exprs, producing the type of the last one. ;; if the list is empty, the type is Void. diff --git a/collects/typed-scheme/private/tc-if-unit.ss b/collects/typed-scheme/private/tc-if-unit.ss index 967307269e..2de7a5289d 100644 --- a/collects/typed-scheme/private/tc-if-unit.ss +++ b/collects/typed-scheme/private/tc-if-unit.ss @@ -96,8 +96,6 @@ (define (tc/if-onearm tst body) (tc/if-twoarm tst body (syntax/loc body (#%app void)))) (define (tc/if-onearm/check tst body expected) - #;(unless (subtype -Void expected) - (tc-error "Single-armed if may return void, but void is not allowed in this context")) (tc/if-twoarm/check tst body (syntax/loc body (#%app void)) expected)) ;; the main function diff --git a/collects/typed-scheme/private/tc-lambda-unit.ss b/collects/typed-scheme/private/tc-lambda-unit.ss index 922cc9730c..0a2b841c69 100644 --- a/collects/typed-scheme/private/tc-lambda-unit.ss +++ b/collects/typed-scheme/private/tc-lambda-unit.ss @@ -40,8 +40,13 @@ [(args* ...) (if (ormap (lambda (e) (not (type-annotation e))) (syntax->list #'(args* ...))) (let* ([arg-list (syntax->list #'(args* ...))]) - (unless (= (length arg-list) (length arg-tys)) - (tc-error "Expected function with ~a arguments, but got function with ~a arguments" (length arg-tys) (length arg-list))) + (let ([arg-list + (if (= (length arg-list) (length arg-tys)) + arg-list + (tc-error/expr + #:return (map (lambda _ (Un)) arg-tys) + "Expected function with ~a arguments, but got function with ~a arguments" + (length arg-tys) (length arg-list)))]) (for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list) (with-lexical-env/extend arg-list arg-tys @@ -172,7 +177,7 @@ (tc/mono-lambda formals bodies expected*))]) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) (ret (make-Poly literal-tvars ty))))] - [_ (tc-error "Expected a value of type ~a, but got a polymorphic function." expected)])) + [_ (tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected)])) ;; form : a syntax object for error reporting diff --git a/collects/typed-scheme/private/tc-toplevel.ss b/collects/typed-scheme/private/tc-toplevel.ss index 8875c21b92..1bef6174ed 100644 --- a/collects/typed-scheme/private/tc-toplevel.ss +++ b/collects/typed-scheme/private/tc-toplevel.ss @@ -225,6 +225,8 @@ (for-each tc-toplevel/pass2 forms) ;; check that declarations correspond to definitions (check-all-registered-types) + ;; report delayed errors + (report-all-errors) ;; compute the new provides (with-syntax ([((new-provs ...) ...) (map (generate-prov stx-defs val-defs) provs)]) diff --git a/collects/typed-scheme/private/tc-utils.ss b/collects/typed-scheme/private/tc-utils.ss index 95383feb2d..4ea5aec86b 100644 --- a/collects/typed-scheme/private/tc-utils.ss +++ b/collects/typed-scheme/private/tc-utils.ss @@ -29,21 +29,34 @@ ;(printf "orig: ~a~n" (syntax-object->datum omodule)) ;(printf "exp: ~a~n" (syntax-object->datum emodule)) ;(printf "stx (locate): ~a~n" (syntax-object->datum stx)) - (if (and omodule emodule stx) + (if (and (not (print-syntax?)) omodule emodule stx) (look-for-in-orig omodule emodule stx) stx)) +(define (raise-typecheck-error msg stxs) + (raise (make-exn:fail:syntax (string-append "typecheck: " msg) + (current-continuation-marks) + stxs))) + +(define delayed-errors null) + +(define-struct err (msg stx) #:prefab) + +(define (report-all-errors) + (define stxs + (for/list ([e (reverse delayed-errors)]) + (thread (lambda () (raise-typecheck-error (err-msg e) (err-stx e)))) + (sleep .01) + (err-stx e))) + (unless (null? stxs) + (raise-typecheck-error "Errors encountered" (apply append stxs)))) + +(define (tc-error/delayed msg #:stx [stx (current-orig-stx)] . rest) + (set! delayed-errors (cons (make-err (apply format msg rest) (list (locate-stx stx))) delayed-errors))) + ;; produce a type error, using the current syntax -(define (tc-error msg . rest) - (define cur-stx - (begin - ;(printf "stx : ~a~n" (current-orig-stx)) - (if (print-syntax?) - (current-orig-stx) - (locate-stx (current-orig-stx))))) - - ;(printf "Aliases: ~a~n" ((current-type-names))) - (raise-syntax-error 'typecheck (apply format msg rest) cur-stx cur-stx)) +(define (tc-error msg . rest) + (raise-typecheck-error (apply format msg rest) (list (locate-stx (current-orig-stx))))) ;; produce a type error, given a particular syntax (define (tc-error/stx stx msg . rest) diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 530af57f8b..a97453abee 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -6,7 +6,8 @@ "type-effect-printer.ss" "union.ss" "subtype.ss" - "type-utils.ss" + "type-utils.ss" + "tc-utils.ss" scheme/promise (for-syntax scheme/base)) @@ -224,4 +225,8 @@ (exit t)))] [_ (exit t)])))) +(define (tc-error/expr msg #:return [return (Un)] #:stx [stx (current-orig-stx)] . rest) + (tc-error/delayed #:stx stx (apply format msg rest)) + return) +