diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index 30b146dc..ee7b3138 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -49,7 +49,8 @@ (define (eqv?-able e) (or (eq?-able e) (number? e))) (define (equal?-able e) #t) (define (ok? val) - (define-syntax-rule (alt nm pred ...) (and (free-identifier=? #'nm comparator) (or (pred val) ...))) + (define-syntax-rule (alt nm pred ...) + (and (free-identifier=? #'nm comparator) (or (pred val) ...))) (or (alt symbol=? symbol?) (alt string=? string?) (alt eq? eq?-able) @@ -189,7 +190,8 @@ [(list tname tfty opt?) (let ([s (cond [(assq tname name-assoc) => cadr] [(not opt?) - (tc-error/delayed "value not provided for named init arg ~a" tname) + (tc-error/delayed "value not provided for named init arg ~a" + tname) #f] [else #f])]) (if s @@ -200,7 +202,8 @@ tnflds) (ret (make-Instance c))] [(tc-result1: t) - (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) + (tc-error/expr #:return (ret (Un)) + "expected a class value for object creation, got: ~a" t)])))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; let loop @@ -265,7 +268,8 @@ (define (tc/app/internal form expected) (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote - values apply k:apply not false? list list* call-with-values do-make-object module-name-fixup cons + values apply k:apply not false? list list* call-with-values + do-make-object module-name-fixup cons map andmap ormap reverse k:reverse extend-parameterization vector-ref unsafe-vector-ref unsafe-vector*-ref vector-set! unsafe-vector-set! unsafe-vector*-set! @@ -284,8 +288,10 @@ [(tc-result1: t) (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) (loop (cddr args))]))))] - ;; use the additional but normally ignored first argument to make-sequence to provide a better instantiation - [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) (~and quo ((~literal quote) (i:id ...))) arg:expr) + ;; use the additional but normally ignored first argument to make-sequence + ;; to provide a better instantiation + [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) + (~and quo ((~literal quote) (i:id ...))) arg:expr) #:when (andmap type-annotation (syntax->list #'(i ...))) (match (single-value #'op) [(tc-result1: (and t Poly?)) @@ -321,15 +327,19 @@ (ret (list-ref flds ival)))]) (if expected (check-below result expected) result))] [(not (and (integer? ival) (exact? ival))) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "expected exact integer for struct index, but got ~a" ival)] [(< ival 0) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "index ~a too small for struct ~a" ival t)] [(not (<= ival (sub1 (length flds)))) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "index ~a too large for struct ~a" ival t)]))] [s-ty (let ([arg-tys (list s-ty e-t)]) (tc/funapp #'op #'(s e) (single-value #'op) arg-tys expected))]))] - [(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr) + [(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) + s e:expr val:expr) (let ([e-t (single-value #'e)]) (match (single-value #'s) [(tc-result1: (and t (or (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _) @@ -341,9 +351,11 @@ [(tc-result1: (Value: (? number? i))) i] [_ #f]))]) (cond [(not ival) - (tc-error/expr #:stx #'e - #:return (or expected (ret -Void)) - "expected statically known index for unsafe struct mutation, but got ~a" (match e-t [(tc-result1: t) t]))] + (tc-error/expr + #:stx #'e + #:return (or expected (ret -Void)) + "expected statically known index for unsafe struct mutation, but got ~a" + (match e-t [(tc-result1: t) t]))] [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds)))) (tc-expr/check #'val (ret (list-ref flds ival))) (if expected @@ -351,18 +363,25 @@ (ret -Void))] [(not (and (integer? ival) (exact? ival))) (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for unsafe struct mutation, but got ~a" ival)] + (tc-error/expr + #:stx #'e #:return (or expected (ret (Un))) + "expected exact integer for unsafe struct mutation, but got ~a" ival)] [(< ival 0) (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "index ~a too small for struct ~a" ival t)] [(not (<= ival (sub1 (length flds)))) (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "index ~a too large for struct ~a" ival t)]))] [s-ty (let ([arg-tys (list s-ty e-t (single-value #'val))]) (tc/funapp #'op #'(s e val) (single-value #'op) arg-tys expected))]))] ;; vector-ref on het vectors - [(#%plain-app (~and op (~or (~literal vector-ref) (~literal unsafe-vector-ref) (~literal unsafe-vector*-ref))) v e:expr) + [(#%plain-app (~and op (~or (~literal vector-ref) + (~literal unsafe-vector-ref) + (~literal unsafe-vector*-ref))) + v e:expr) (let ([e-t (single-value #'e)]) (let loop ((v-t (single-value #'v))) (match v-t @@ -381,17 +400,23 @@ (check-below (ret (list-ref es ival)) expected) (ret (list-ref es ival)))] [(not (and (integer? ival) (exact? ival))) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "expected exact integer for vector index, but got ~a" ival)] [(< ival 0) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "index ~a too small for vector ~a" ival t)] [(not (<= ival (sub1 (length es)))) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "index ~a too large for vector ~a" ival t)]))] [(tc-result1: (? needs-resolving? e) f o) (loop (ret (resolve-once e) f o))] [v-ty (let ([arg-tys (list v-ty e-t)]) (tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))])))] - [(#%plain-app (~and op (~or (~literal vector-set!) (~literal unsafe-vector-set!) (~literal unsafe-vector*-set!))) v e:expr val:expr) + [(#%plain-app (~and op (~or (~literal vector-set!) + (~literal unsafe-vector-set!) + (~literal unsafe-vector*-set!))) + v e:expr val:expr) (let ([e-t (single-value #'e)]) (let loop ((v-t (single-value #'v))) (match v-t @@ -401,9 +426,10 @@ [(tc-result1: (Value: (? number? i))) i] [_ #f]))]) (cond [(not ival) - (tc-error/expr #:stx #'e - #:return (or expected (ret -Void)) - "expected statically known index for heterogeneous vector, but got ~a" (match e-t [(tc-result1: t) t]))] + (tc-error/expr + #:stx #'e #:return (or expected (ret -Void)) + "expected statically known index for heterogeneous vector, but got ~a" + (match e-t [(tc-result1: t) t]))] [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es)))) (tc-expr/check #'val (ret (list-ref es ival))) (if expected @@ -411,13 +437,16 @@ (ret -Void))] [(not (and (integer? ival) (exact? ival))) (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "expected exact integer for vector index, but got ~a" ival)] [(< ival 0) (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "index ~a too small for vector ~a" ival t)] [(not (<= ival (sub1 (length es)))) (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))] + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) + "index ~a too large for vector ~a" ival t)]))] [(tc-result1: (? needs-resolving? e) f o) (loop (ret (resolve-once e) f o))] [v-ty @@ -452,12 +481,14 @@ (tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected)) (check-below (for/first ([t ts]) (loop (ret t))) expected))] - ;; since vectors are mutable, if there is no expected type, we want to generalize the element type + ;; since vectors are mutable, if there is no expected type, + ;; we want to generalize the element type [(or #f (tc-result1: _)) (ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x))) (syntax->list #'(args ...)))))] [_ (int-err "bad expected: ~a" expected)]))] - ;; since vectors are mutable, if there is no expected type, we want to generalize the element type + ;; since vectors are mutable, if there is no expected type, + ;; we want to generalize the element type [(#%plain-app (~and op (~literal make-vector)) n elt) (match expected [(tc-result1: (Vector: t)) @@ -495,14 +526,17 @@ [(subtype t -PosFixnum) (ret -NonNegFixnum)] [(subtype t -NonNegFixnum) (ret -Fixnum)] [(subtype t -PosInt) (ret -Nat)] - [else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))] + [else (tc/funapp #'op #'(v arg2) (single-value #'op) + (list (ret t) (single-value #'arg2)) expected)]))] ;; idem for fx- - [(#%plain-app (~and op (~or (~literal fx-) (~literal unsafe-fx-))) v (~and arg2 ((~literal quote) 1))) + [(#%plain-app (~and op (~or (~literal fx-) (~literal unsafe-fx-))) + v (~and arg2 ((~literal quote) 1))) (add-typeof-expr #'arg2 (ret -PosFixnum)) (match-let ([(tc-result1: t) (single-value #'v)]) (cond [(subtype t -PosInt) (ret -NonNegFixnum)] - [else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))] + [else (tc/funapp #'op #'(v arg2) (single-value #'op) + (list (ret t) (single-value #'arg2)) expected)]))] ;; call-with-values [(#%plain-app call-with-values prod con) (match (tc/funapp #'prod #'() (single-value #'prod) null #f) @@ -511,7 +545,8 @@ ;; in eq? cases, call tc/eq [(#%plain-app eq?:comparator v1 v2) ;; make sure the whole expression is type correct - (match* ((tc/funapp #'eq? #'(v1 v2) (single-value #'eq?) (map single-value (syntax->list #'(v1 v2))) expected) + (match* ((tc/funapp #'eq? #'(v1 v2) (single-value #'eq?) + (map single-value (syntax->list #'(v1 v2))) expected) ;; check thn and els with the eq? info (tc/eq #'eq? #'v1 #'v2)) [((tc-result1: t) (tc-result1: t* f o)) @@ -528,10 +563,12 @@ [(tc-result1: (List: ts)) (ret ts)] [_ (tc/apply #'values #'(e))])] ;; rewrite this so that it takes advantages of all the special cases - [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)] + [(#%plain-app k:apply . args) + (tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)] ;; handle apply specially [(#%plain-app apply f . args) (tc/apply #'f #'args)] - ;; special case for `values' with single argument - we just ignore the values, except that it forces arg to return one value + ;; special case for `values' with single argument + ;; we just ignore the values, except that it forces arg to return one value [(#%plain-app values arg) (match expected [#f (single-value #'arg)] @@ -568,14 +605,16 @@ #:declare s-kp (id-from 'struct:keyword-procedure 'racket/private/kw) #:declare kpe (id-from 'keyword-procedure-extract 'racket/private/kw) (match (tc-expr #'fn) - [(tc-result1: (Poly: vars - (Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals)))))) + [(tc-result1: + (Poly: vars + (Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals)))))) (=> fail) (unless (null? (fv/list kw-formals)) (fail)) (match (map single-value (syntax->list #'pos-args)) [(list (tc-result1: argtys-t) ...) - (let* ([subst (infer vars null argtys-t dom rng (and expected (tc-results->values expected)))]) + (let* ([subst (infer vars null argtys-t dom rng + (and expected (tc-results->values expected)))]) (unless subst (fail)) (tc-keywords form (list (subst-all subst ar)) (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] @@ -584,8 +623,9 @@ [(tc-result1: (Poly: _ (Function: _))) (tc-error/expr #:return (ret (Un)) "Inference for polymorphic keyword functions not supported")] - [(tc-result1: t) (tc-error/expr #:return (ret (Un)) - "Cannot apply expression of type ~a, since it is not a function type" t)])] + [(tc-result1: t) + (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals) #:fail-unless expected #f @@ -599,7 +639,9 @@ [(#%plain-app module-name-fixup src path) (ret Univ)] ;; special cases for classes - [(#%plain-app do-make-object b cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...)) + [(#%plain-app do-make-object b cl + (#%plain-app list . pos-args) + (#%plain-app list (#%plain-app cons 'names named-args) ...)) (check-do-make-object #'b #'cl #'pos-args #'(names ...) #'(named-args ...))] [(#%plain-app do-make-object args ...) (int-err "unexpected arguments to do-make-object")] @@ -609,8 +651,10 @@ [((tc-result1: (ListDots: t0 bound0)) (list (tc-result1: (or (and (ListDots: t bound) (app (λ _ #f) var)) ;; a devious hack - just generate #f so the test below succeeds - ;; have to explicitly bind `var' since otherwise `var' appears on only one side of the or - ;; NOTE: safe to include these, `map' will error if any list is not the same length as all the others + ;; have to explicitly bind `var' since otherwise `var' appears + ;; on only one side of the or + ;; NOTE: safe to include these, `map' will error if any list is + ;; not the same length as all the others (and (Listof: t var) (app (λ _ #f) bound)))) ...)) (=> fail) @@ -624,7 +668,8 @@ "Expected one value, but got ~a" (-values ts))])] ;; otherwise, if it's not a ListDots, defer to the regular function typechecking [(res0 res) - (tc/funapp #'map-expr #'(f arg0 arg ...) (single-value #'map-expr) (list* (tc-expr #'f) res0 res) expected)])] + (tc/funapp #'map-expr #'(f arg0 arg ...) (single-value #'map-expr) + (list* (tc-expr #'f) res0 res) expected)])] ;; ormap/andmap of ... argument [(#%plain-app (~and fun (~or (~literal andmap) (~literal ormap))) f arg) ;; check the arguments @@ -710,7 +755,8 @@ ;; on rst is not a normal annotation, may have * or ... #:fail-when (type-annotation #'rst) #f #:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f - (let-values ([(fixed-args varargs) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) + (let-values ([(fixed-args varargs) + (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))]) (with-syntax ([(fixed-args ...) fixed-args] [varg #`(#%plain-app list #,@varargs)]) (tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body