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

Refactor tc-send, delete trailing whitespace

Browse Source 
original commit: ba7703b015a998bc9e18f61cb487a3a4f7a8adab
This commit is contained in:
Asumu Takikawa 2014-06-09 15:36:38 -04:00
parent 15bc190252
commit 64a4fd6e1d
1 changed files with 22 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
View File

@ -1,11 +1,12 @@
#lang racket/unit
;; This module provides typechecking for `send` method calls
(require "../utils/utils.rkt"
racket/match syntax/stx
(typecheck signatures tc-funapp)
(types base-abbrev resolve utils type-table)
(rep type-rep)
(rep type-rep)
(utils tc-utils))
(import tc-expr^)
@ -13,24 +14,27 @@
(define (tc/send form rcvr method args [expected #f])
(define (do-check rcvr-type)
(match rcvr-type
[(tc-result1: (Instance: (? needs-resolving? type)))
(do-check (ret (make-Instance (resolve type))))]
[(tc-result1: (and obj (Instance: (Class: _ _ _ methods _ _))))
(match (tc-expr method)
[(tc-result1: (Value: (? symbol? s)))
(let* ([ftype (cond [(assq s methods) => cadr]
[else (tc-error/expr/fields "send: method not understood by object"
"method name" s
"object type" obj
#:return -Bottom)])]
[retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr 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/fields
(match rcvr-type
[(tc-result1: (Instance: (? needs-resolving? type)))
(do-check (ret (make-Instance (resolve type))))]
[(tc-result1: (and obj (Instance: (Class: _ _ _ methods _ _))))
(match (tc-expr method)
[(tc-result1: (Value: (? symbol? s)))
(define ftype
(cond [(assq s methods) => cadr]
[else (tc-error/expr/fields
"send: method not understood by object"
"method name" s
"object type" obj
#:return -Bottom)]))
(define retval
(tc/funapp rcvr args (ret ftype) (stx-map tc-expr 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/fields
"send: type mismatch"
"expected" "an object"
"given" t)]))
(do-check (tc-expr rcvr)))