Replace tc-error/expr with tc-error/delayed where appropriate.
This commit is contained in:
Eric Dobson
parent
2cf652eccf
commit
ef98a582cb
|
|
@ -4,6 +4,7 @@
|
|||
;; maps identifiers to their types, updated by mutation
|
||||
|
||||
(require "../types/tc-error.rkt"
|
||||
"../utils/tc-utils.rkt"
|
||||
syntax/parse
|
||||
syntax/id-table
|
||||
racket/lazy-require)
|
||||
|
|
@ -35,7 +36,7 @@
|
|||
=> (lambda (e)
|
||||
(define t (if (box? e) (unbox e) e))
|
||||
(unless (and (Type/c? t) (type-equal? t type))
|
||||
(tc-error/expr #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t))
|
||||
(tc-error/delayed #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t))
|
||||
(when (box? e)
|
||||
(free-id-table-set! the-mapping id t)))]
|
||||
[else (register-type id type)]))
|
||||
|
|
@ -49,7 +50,7 @@
|
|||
(λ (t) ;; it's ok to annotate with the same type
|
||||
(define t* (if (box? t) (unbox t) t))
|
||||
(unless (and (Type/c? t*) (type-equal? type t*))
|
||||
(void (tc-error/expr #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t*))))]
|
||||
(tc-error/delayed #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t*)))]
|
||||
[else (free-id-table-set! the-mapping id (box type))]))
|
||||
|
||||
;; add a bunch of types to the mapping
|
||||
|
|
@ -83,8 +84,7 @@
|
|||
|
||||
(define (finish-register-type id [top-level? #f])
|
||||
(unless (or (maybe-finish-register-type id) top-level?)
|
||||
(tc-error/expr #:stx id "Duplicate definition for ~a" (syntax-e id)))
|
||||
(void))
|
||||
(tc-error/delayed #:stx id "Duplicate definition for ~a" (syntax-e id))))
|
||||
|
||||
(define (check-all-registered-types)
|
||||
(free-id-table-for-each
|
||||
|
|
@ -92,13 +92,12 @@
|
|||
(lambda (id e)
|
||||
(when (box? e)
|
||||
(let ([bnd (identifier-binding id)])
|
||||
(tc-error/expr #:stx id
|
||||
"Declaration for `~a' provided, but `~a' ~a"
|
||||
(syntax-e id) (syntax-e id)
|
||||
(cond [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen
|
||||
[(not bnd) "has no definition"]
|
||||
[else "is defined in another module"]))))
|
||||
(void))))
|
||||
(tc-error/delayed #:stx id
|
||||
"Declaration for `~a' provided, but `~a' ~a"
|
||||
(syntax-e id) (syntax-e id)
|
||||
(cond [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen
|
||||
[(not bnd) "has no definition"]
|
||||
[else "is defined in another module"])))))))
|
||||
|
||||
;; map over the-mapping, producing a list
|
||||
;; (id type -> T) -> listof[T]
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@
|
|||
(define t2 (lookup-type stx (lambda () #f)))
|
||||
(when (and t2 (not (type-equal? t1 t2)))
|
||||
(maybe-finish-register-type stx)
|
||||
(tc-error/expr #:stx stx "Duplicate type annotation of ~a for ~a, previous was ~a" t1 (syntax-e stx) t2)))
|
||||
(tc-error/delayed #:stx stx "Duplicate type annotation of ~a for ~a, previous was ~a" t1 (syntax-e stx) t2)))
|
||||
(if (syntax? prop)
|
||||
(parse-type prop)
|
||||
(parse-type/id stx prop)))
|
||||
|
|
@ -114,11 +114,9 @@
|
|||
(length stxs)))]
|
||||
[(tc-results: tys fs os)
|
||||
(if (not (= (length stxs) (length tys)))
|
||||
(begin
|
||||
(tc-error/delayed
|
||||
"Expression should produce ~a values, but produces ~a values of types ~a"
|
||||
(length stxs) (length tys) (stringify tys))
|
||||
(ret (map (lambda _ (Un)) stxs)))
|
||||
(tc-error/expr #:return (ret (map (lambda _ (Un)) stxs))
|
||||
"Expression should produce ~a values, but produces ~a values of types ~a"
|
||||
(length stxs) (length tys) (stringify tys))
|
||||
(combine-results
|
||||
(for/list ([stx (in-list stxs)] [ty (in-list tys)]
|
||||
[a (in-list anns)] [f (in-list fs)] [o (in-list os)])
|
||||
|
|
|
|||
|
|
@ -34,8 +34,7 @@
|
|||
(define (type-mismatch t1 t2 [more #f])
|
||||
(define t1* (if (Type/c? t1) (pretty-format-type t1 #:indent 12) t1))
|
||||
(define t2* (if (Type/c? t2) (pretty-format-type t2 #:indent 9) t2))
|
||||
(tc-error/expr/fields "type mismatch" #:more more
|
||||
"expected" t1* "given" t2*))
|
||||
(tc-error/fields "type mismatch" #:more more "expected" t1* "given" t2* #:delayed? #t))
|
||||
|
||||
;; expected-but-got : (U Type String) (U Type String) -> Void
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -330,11 +330,12 @@
|
|||
(values super-row super-inits super-fields
|
||||
super-methods super-augments super-init-rest)]
|
||||
[t
|
||||
(tc-error/expr/fields "type mismatch"
|
||||
#:more "superclass expression should produce a class"
|
||||
#:stx (hash-ref parse-info 'superclass-expr)
|
||||
"expected" "a class"
|
||||
"given" t)
|
||||
(tc-error/fields "type mismatch"
|
||||
#:more "superclass expression should produce a class"
|
||||
#:stx (hash-ref parse-info 'superclass-expr)
|
||||
#:delayed? #t
|
||||
"expected" "a class"
|
||||
"given" t)
|
||||
(values #f null null null null #f)])]
|
||||
[_ (int-err "Unhandled result")]))
|
||||
(define super-init-names (dict-keys super-inits))
|
||||
|
|
@ -526,7 +527,7 @@
|
|||
other-exprs]
|
||||
[:tr:class:super-new^
|
||||
(when super-new
|
||||
(tc-error/expr "typed classes must only call super-new a single time"))
|
||||
(tc-error/delayed "typed classes must only call super-new a single time"))
|
||||
(set! super-new (find-provided-inits expr))
|
||||
other-exprs]
|
||||
[(~and t:class-type-declaration :tr:class:type-annotation^)
|
||||
|
|
@ -544,7 +545,7 @@
|
|||
other-exprs]
|
||||
[_ (cons expr other-exprs)])))
|
||||
(unless super-new
|
||||
(tc-error/expr "typed classes must call super-new at the class top-level")
|
||||
(tc-error/delayed "typed classes must call super-new at the class top-level")
|
||||
(set! super-new (super-init-stxs null null)))
|
||||
(values super-new
|
||||
initializers
|
||||
|
|
@ -924,7 +925,7 @@
|
|||
;; type error instead.
|
||||
(with-handlers
|
||||
([exn:fail:syntax?
|
||||
(λ (e) (tc-error/expr "Default init value has wrong type"))])
|
||||
(λ (e) (tc-error/delayed "Default init value has wrong type"))])
|
||||
(parameterize ([delay-errors? #f])
|
||||
(unless (equal? (syntax->datum #'init-val) '(quote #f))
|
||||
(tc-expr/check #'init-val (ret (Un init-type (->* null init-type)))))))]
|
||||
|
|
@ -935,8 +936,8 @@
|
|||
;; should it be caught earlier so that this function
|
||||
;; can be simpler?
|
||||
[else
|
||||
(tc-error/expr "Init argument ~a has no type annotation"
|
||||
init-name)])]
|
||||
(tc-error/delayed "Init argument ~a has no type annotation"
|
||||
init-name)])]
|
||||
;; init-field with default
|
||||
[(let-values (((obj1:id) self:id))
|
||||
(let-values (((x:id)
|
||||
|
|
@ -954,13 +955,13 @@
|
|||
(with-handlers
|
||||
([exn:fail:syntax?
|
||||
;; FIXME: produce a better error message
|
||||
(λ (e) (tc-error/expr "Default init value has wrong type"))])
|
||||
(λ (e) (tc-error/delayed "Default init value has wrong type"))])
|
||||
(parameterize ([delay-errors? #f])
|
||||
(unless (equal? (syntax->datum #'init-val) '(quote #f))
|
||||
(tc-expr/check #'init-val (ret (Un init-type (->* null init-type)))))))]
|
||||
[else
|
||||
(tc-error/expr "Init argument ~a has no type annotation"
|
||||
init-name)])]
|
||||
(tc-error/delayed "Init argument ~a has no type annotation"
|
||||
init-name)])]
|
||||
;; any field or init-field without default
|
||||
;; FIXME: could use the local table to make sure the
|
||||
;; setter is known as a sanity check
|
||||
|
|
@ -1157,12 +1158,12 @@
|
|||
(match-define (super-init-stxs _ by-name) init-stxs)
|
||||
(for ([(name _) (in-dict by-name)])
|
||||
(unless (dict-ref super-inits name #f)
|
||||
(tc-error/expr/fields
|
||||
(tc-error/fields
|
||||
"invalid `super-new' or `super-instantiate'"
|
||||
#:more "init argument not accepted by superclass"
|
||||
"init name" name
|
||||
#:stx #`#,name
|
||||
#:return #f))))
|
||||
#:delayed? #t))))
|
||||
|
||||
;; check-super-new : super-init-stxs Dict Type -> Void
|
||||
;; Check if the super-new call is well-typed
|
||||
|
|
@ -1413,9 +1414,9 @@
|
|||
(for/or ([m (in-set required)])
|
||||
(and (not (set-member? actual m)) m)))
|
||||
(when missing
|
||||
(tc-error/expr (~a "superclass missing ~a ~a "
|
||||
"that the current class requires")
|
||||
msg missing)))
|
||||
(tc-error/delayed (~a "superclass missing ~a ~a "
|
||||
"that the current class requires")
|
||||
msg missing)))
|
||||
|
||||
;; Set<Symbol> Set<Symbol> String -> Void
|
||||
;; check that names are absent when they should be
|
||||
|
|
@ -1424,8 +1425,8 @@
|
|||
(for/or ([m (in-set should-be-absent)])
|
||||
(and (set-member? actual m) m)))
|
||||
(when present
|
||||
(tc-error/expr "superclass defines conflicting ~a ~a"
|
||||
msg present)))
|
||||
(tc-error/delayed "superclass defines conflicting ~a ~a"
|
||||
msg present)))
|
||||
|
||||
;; Set<Symbol> Set<Symbol> String -> Void
|
||||
;; check that the names are exactly the same as expected
|
||||
|
|
@ -1434,13 +1435,13 @@
|
|||
(for/or ([m (in-set expected)])
|
||||
(and (not (set-member? actual m)) m)))
|
||||
(when missing
|
||||
(tc-error/expr (~a "class definition missing ~a ~a "
|
||||
"that is required by the expected type")
|
||||
msg missing))
|
||||
(tc-error/delayed (~a "class definition missing ~a ~a "
|
||||
"that is required by the expected type")
|
||||
msg missing))
|
||||
(define too-many
|
||||
(for/or ([m (in-set actual)])
|
||||
(and (not (set-member? expected m)) m)))
|
||||
(when too-many
|
||||
(tc-error/expr (~a "class definition contains ~a ~a "
|
||||
"that is not in the expected type")
|
||||
msg too-many)))
|
||||
(tc-error/delayed (~a "class definition contains ~a ~a "
|
||||
"that is not in the expected type")
|
||||
msg too-many)))
|
||||
|
|
|
|||
|
|
@ -23,27 +23,18 @@
|
|||
(list (tc-result1: t-a phi-a o-a) ...))
|
||||
|
||||
(when check?
|
||||
(define error-ret
|
||||
(match rng
|
||||
((AnyValues:) tc-any-results)
|
||||
((Values: (list (Result: t-r _ _) ...)) (ret t-r))
|
||||
((ValuesDots: (list (Result: t-r _ _) ...) dty dbound)
|
||||
(ret t-r
|
||||
(make-list (length t-r) -top-filter)
|
||||
(make-list (length t-r) -empty-obj)
|
||||
dty dbound))))
|
||||
(cond [(and (not rest) (not (= (length dom) (length t-a))))
|
||||
(tc-error/expr/fields "could not apply function"
|
||||
#:more "wrong number of arguments provided"
|
||||
"expected" (length dom)
|
||||
"given" (length t-a)
|
||||
#:return error-ret)]
|
||||
(tc-error/fields "could not apply function"
|
||||
#:more "wrong number of arguments provided"
|
||||
"expected" (length dom)
|
||||
"given" (length t-a)
|
||||
#:delayed? #t)]
|
||||
[(and rest (< (length t-a) (length dom)))
|
||||
(tc-error/expr/fields "could not apply function"
|
||||
#:more "wrong number of arguments provided"
|
||||
"expected at least" (length dom)
|
||||
"given" (length t-a)
|
||||
#:return error-ret)])
|
||||
(tc-error/fields "could not apply function"
|
||||
#:more "wrong number of arguments provided"
|
||||
"expected at least" (length dom)
|
||||
"given" (length t-a)
|
||||
#:delayed? #t)])
|
||||
(for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))]
|
||||
[a (in-syntax args-stx)]
|
||||
[arg-t (in-list t-a)])
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
syntax/parse syntax/stx racket/match unstable/sequence unstable/syntax
|
||||
"signatures.rkt"
|
||||
"utils.rkt"
|
||||
(utils tc-utils)
|
||||
(types utils abbrev numeric-tower union resolve type-table generalize)
|
||||
(typecheck signatures check-below)
|
||||
(rep type-rep rep-utils)
|
||||
|
|
|
|||
|
|
@ -153,10 +153,11 @@
|
|||
(λ (field-entry)
|
||||
(define field-type (cadr field-entry))
|
||||
(unless (subtype val-type field-type)
|
||||
(tc-error/expr/fields "type mismatch"
|
||||
#:more "set-field! only allowed with compatible types"
|
||||
"expected" field-type
|
||||
"given" val-type))
|
||||
(tc-error/fields "type mismatch"
|
||||
#:more "set-field! only allowed with compatible types"
|
||||
"expected" field-type
|
||||
"given" val-type
|
||||
#:delayed? #t))
|
||||
(ret -Void))]
|
||||
[else
|
||||
(tc-error/expr/fields "type mismatch"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user