Use tc-result1: instead of tc-result: in object handling.
Use tc-results->values instead of bogus version. svn: r14937
This commit is contained in:
parent
e92a8dd2f5
commit
0feb99f6bc
|
@ -3,7 +3,7 @@
|
||||||
(require (except-in "../utils/utils.ss" extend))
|
(require (except-in "../utils/utils.ss" extend))
|
||||||
(require syntax/kerncase
|
(require syntax/kerncase
|
||||||
scheme/match
|
scheme/match
|
||||||
"signatures.ss"
|
"signatures.ss" "tc-metafunctions.ss"
|
||||||
(types utils convenience union subtype)
|
(types utils convenience union subtype)
|
||||||
(utils tc-utils)
|
(utils tc-utils)
|
||||||
(rep type-rep))
|
(rep type-rep))
|
||||||
|
@ -61,8 +61,7 @@
|
||||||
[stx
|
[stx
|
||||||
;; this is a hander function
|
;; this is a hander function
|
||||||
(syntax-property form 'typechecker:exn-handler)
|
(syntax-property form 'typechecker:exn-handler)
|
||||||
(tc-expr/check form (match expected
|
(tc-expr/check form (ret (-> (Un) (tc-results->values expected))))]
|
||||||
[(tc-result1: e) (ret (-> (Un) e))]))]
|
|
||||||
[stx
|
[stx
|
||||||
;; this is the body of the with-handlers
|
;; this is the body of the with-handlers
|
||||||
(syntax-property form 'typechecker:exn-body)
|
(syntax-property form 'typechecker:exn-body)
|
||||||
|
|
|
@ -355,17 +355,17 @@
|
||||||
|
|
||||||
(define (tc/send rcvr method args [expected #f])
|
(define (tc/send rcvr method args [expected #f])
|
||||||
(match (tc-expr rcvr)
|
(match (tc-expr rcvr)
|
||||||
[(tc-result: (Instance: (and c (Class: _ _ methods))))
|
[(tc-result1: (Instance: (and c (Class: _ _ methods))))
|
||||||
(match (tc-expr method)
|
(match (tc-expr method)
|
||||||
[(tc-result: (Value: (? symbol? s)))
|
[(tc-result1: (Value: (? symbol? s)))
|
||||||
(let* ([ftype (cond [(assq s methods) => cadr]
|
(let* ([ftype (cond [(assq s methods) => cadr]
|
||||||
[else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
|
[else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
|
||||||
[ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)])
|
[ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)])
|
||||||
(if expected
|
(if expected
|
||||||
(begin (check-below ret-ty expected) (ret expected))
|
(begin (check-below ret-ty expected) (ret expected))
|
||||||
ret-ty))]
|
ret-ty))]
|
||||||
[(tc-result: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])]
|
[(tc-result1: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])]
|
||||||
[(tc-result: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~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 (single-value form [expected #f])
|
||||||
(define t (if expected (tc-expr/check form expected) (tc-expr form)))
|
(define t (if expected (tc-expr/check form expected) (tc-expr form)))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user