diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index 848c439d..080182b8 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -2,6 +2,7 @@ (require "../utils/utils.rkt" "tc-app/signatures.rkt" + "tc-app/utils.rkt" syntax/parse racket/match syntax/parse/experimental/reflect (typecheck signatures check-below tc-funapp) @@ -15,38 +16,46 @@ (export tc-app^) -;; the main dispatching function -;; syntax tc-results? -> tc-results? -(define (tc/app/internal form expected) - (syntax-parse form - [(#%plain-app . - (~or (~var v (tc/app-annotated expected)) - (~reflect v (tc/app-list expected) #:attributes (check)) - (~reflect v (tc/app-apply expected) #:attributes (check)) - (~reflect v (tc/app-eq expected) #:attributes (check)) - (~reflect v (tc/app-hetero expected) #:attributes (check)) - (~reflect v (tc/app-values expected) #:attributes (check)) - (~reflect v (tc/app-keywords expected) #:attributes (check)) - (~reflect v (tc/app-objects expected) #:attributes (check)) - (~reflect v (tc/app-lambda expected) #:attributes (check)) - (~reflect v (tc/app-special expected) #:attributes (check)) - (~var v (tc/app-regular* expected)))) - ((attribute v.check))])) - (define-syntax-class annotated-op (pattern i:identifier #:when (or (syntax-property #'i 'type-inst) (syntax-property #'i 'type-ascription)))) - -(define-syntax-class (tc/app-annotated expected) +(define-tc/app-syntax-class (tc/app-annotated expected) ;; Just do regular typechecking if we have one of these. (pattern (~and form (rator:annotated-op . rands)) - #:attr check (lambda () (tc/app-regular #'form expected)))) + (tc/app-regular #'form expected))) + +(define-tc/app-syntax-class (tc/app-regular* expected) + (pattern form (tc/app-regular #'form expected))) + +(define-syntax-rule (combine-tc/app-syntax-classes class-name case ...) + (define-syntax-class (class-name expected) + #:attributes (check) + (pattern (~reflect v (case expected) #:attributes (check)) + #:attr check (attribute v.check)) ...)) + +(combine-tc/app-syntax-classes tc/app-special-cases + tc/app-annotated + tc/app-list + tc/app-apply + tc/app-eq + tc/app-hetero + tc/app-values + tc/app-keywords + tc/app-objects + tc/app-lambda + tc/app-special + tc/app-regular*) + +;; the main dispatching function +;; syntax tc-results? -> tc-results? +(define (tc/app/internal form expected) + (syntax-parse form + [(#%plain-app . (~var v (tc/app-special-cases expected))) + ((attribute v.check))])) + -(define-syntax-class (tc/app-regular* expected) - (pattern form - #:attr check (lambda () (tc/app-regular #'form expected)))) (define (tc/app-regular form expected) (syntax-parse form diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt index 37024e4c..68bb04dd 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt @@ -83,32 +83,32 @@ unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set! vector-immutable vector) - (pattern ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr) + (pattern (~and form ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr)) (match (single-value #'struct) [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)))) (tc/hetero-ref #'index flds struct-t expected "struct")] - [s-ty #f])) + [s-ty (tc/app-regular #'form expected)])) ;; vector-ref on het vectors - (pattern ((~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr) + (pattern (~and form ((~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr)) (match (single-value #'vec) [(tc-result1: (and vec-t (app resolve (HeterogenousVector: es)))) (tc/hetero-ref #'index es vec-t expected "vector")] - [v-ty #f])) + [v-ty (tc/app-regular #'form expected)])) ;; unsafe struct-set! - (pattern ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr) + (pattern (~and form ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr)) (match (single-value #'s) [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)))) (tc/hetero-set! #'index flds #'val struct-t expected "struct")] - [s-ty #f])) + [s-ty (tc/app-regular #'form expected)])) ;; vector-set! on het vectors - (pattern ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr) + (pattern (~and form ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr)) (match (single-value #'v) [(tc-result1: (and vec-t (app resolve (HeterogenousVector: es)))) (tc/hetero-set! #'index es #'val vec-t expected "vector")] - [v-ty #f])) + [v-ty (tc/app-regular #'form expected)])) (pattern (~and form ((~or vector-immutable vector) args:expr ...)) (match expected - [(tc-result1: (app resolve (Vector: t))) #f] + [(tc-result1: (app resolve (Vector: t))) (tc/app-regular #'form expected)] [(tc-result1: (app resolve (HeterogenousVector: ts))) (unless (= (length ts) (length (syntax->list #'(args ...)))) (tc-error/expr "expected vector with ~a elements, but got ~a"