diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index 3ab38ef9..269dc8aa 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -24,6 +24,9 @@ (define-signature tc-literal^ ([cond-contracted tc-literal (->* (syntax?) ((or/c Type/c #f)) Type/c)])) +(define-signature tc-send^ + ([cond-contracted tc/send ((syntax? syntax? syntax? syntax?) ((or/c tc-results/c #f)) . ->* . tc-results/c)])) + (define-signature tc-lambda^ ([cond-contracted tc/lambda (syntax? syntax? syntax? . -> . tc-results/c)] [cond-contracted tc/lambda/check (syntax? syntax? syntax? tc-results/c . -> . tc-results/c)] diff --git a/collects/typed-racket/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt index 99dac1b1..01fea347 100644 --- a/collects/typed-racket/typecheck/tc-expr-unit.rkt +++ b/collects/typed-racket/typecheck/tc-expr-unit.rkt @@ -10,17 +10,17 @@ (private-in parse-type type-annotation) (rep type-rep filter-rep object-rep) (only-in (infer infer) restrict) - (except-in (utils tc-utils stxclass-util)) + (utils tc-utils stxclass-util) (env lexical-env type-env-structs tvar-env index-env) racket/private/class-internal - (except-in syntax/parse id) + syntax/parse unstable/function #;unstable/debug (only-in srfi/1 split-at) (for-template "internal-forms.rkt" (only-in '#%paramz [parameterization-key pz:pk]))) (require (for-template racket/base racket/private/class-internal)) -(import tc-if^ tc-lambda^ tc-app^ tc-let^ check-subforms^ tc-literal^) +(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-send^ check-subforms^ tc-literal^) (export tc-expr^) ;; do-inst : syntax type -> type @@ -414,20 +414,6 @@ (add-typeof-expr form r) r)]))]))) -(define/cond-contract (tc/send form rcvr method args [expected #f]) - (-->* (syntax? syntax? syntax? syntax?) ((-or/c tc-results/c #f)) tc-results/c) - (match (tc-expr rcvr) - [(tc-result1: (Instance: (and c (Class: _ _ methods)))) - (match (tc-expr method) - [(tc-result1: (Value: (? symbol? s))) - (let* ([ftype (cond [(assq s methods) => cadr] - [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] - [retval (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)]) - (add-typeof-expr form retval) - retval)] - [(tc-result1: t) (int-err "non-symbol methods not supported by Typed Racket: ~a" t)])] - [(tc-result1: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)])) - (define (single-value form [expected #f]) (define t (if expected (tc-expr/check form expected) (tc-expr form))) (match t diff --git a/collects/typed-racket/typecheck/tc-send.rkt b/collects/typed-racket/typecheck/tc-send.rkt new file mode 100644 index 00000000..7ea1e709 --- /dev/null +++ b/collects/typed-racket/typecheck/tc-send.rkt @@ -0,0 +1,27 @@ +#lang racket/unit + + +(require "../utils/utils.rkt" + racket/match + (typecheck signatures tc-funapp) + (types base-abbrev utils type-table) + (rep type-rep) + (utils tc-utils)) + +(import tc-expr^) +(export tc-send^) + +(define/cond-contract (tc/send form rcvr method args [expected #f]) + (-->* (syntax? syntax? syntax? syntax?) ((-or/c tc-results/c #f)) tc-results/c) + (match (tc-expr rcvr) + [(tc-result1: (Instance: (and c (Class: _ _ methods)))) + (match (tc-expr method) + [(tc-result1: (Value: (? symbol? s))) + (let* ([ftype (cond [(assq s methods) => cadr] + [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] + [retval (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)]) + (add-typeof-expr form retval) + retval)] + [(tc-result1: t) (int-err "non-symbol methods not supported by Typed Racket: ~a" t)])] + [(tc-result1: t) (tc-error/expr #:return (or expected (ret -Bottom)) "send: expected a class instance, got ~a" t)])) + diff --git a/collects/typed-racket/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt index c2c7078e..61e31498 100644 --- a/collects/typed-racket/typecheck/typechecker.rkt +++ b/collects/typed-racket/typecheck/typechecker.rkt @@ -10,10 +10,11 @@ "tc-if.rkt" "tc-lambda-unit.rkt" "tc-let-unit.rkt" "tc-apply.rkt" "tc-literal.rkt" + "tc-send.rkt" "tc-expr-unit.rkt" "check-subforms-unit.rkt") (provide-signature-elements tc-expr^ check-subforms^ tc-literal^) (define-values/invoke-unit/infer (link tc-if@ tc-lambda@ tc-app-combined@ tc-let@ tc-expr@ - check-subforms@ tc-apply@ tc-literal@)) + tc-send@ check-subforms@ tc-apply@ tc-literal@))