suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move tc/send to new file because it doesn't belong in tc-expr-unit.

Browse Source 
original commit: 8db95d007a09b0ebad8d10d6b321dd36dd142355
This commit is contained in:
Eric Dobson 2013-02-05 20:49:16 -08:00
parent b10ead12a1
commit 1c4fa12acd
4 changed files with 35 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/typed-racket/typecheck/signatures.rkt
View File

@ -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)]

20
collects/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -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

27
collects/typed-racket/typecheck/tc-send.rkt Normal file
View File

@ -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)]))

3
collects/typed-racket/typecheck/typechecker.rkt
View File

@ -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@))