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

Attempt to support recursive types in classes better

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-24 20:54:05 -04:00
parent 16ca57500b
commit a1efc2c276
2 changed files with 17 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -149,6 +149,8 @@
;; class produced by class: due to the syntax property ;; class produced by class: due to the syntax property
(define (check-class form [expected #f]) (define (check-class form [expected #f])
(match expected (match expected
[(tc-result1: (? Mu? type))
(check-class form (ret (unfold type)))]
[(tc-result1: (and self-class-type (Class: _ _ _ _))) [(tc-result1: (and self-class-type (Class: _ _ _ _)))
(do-check form #t self-class-type)] (do-check form #t self-class-type)]
[#f (do-check form #f #f)])) [#f (do-check form #f #f)]))

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

@ -12,15 +12,19 @@
(export tc-send^) (export tc-send^)
(define (tc/send form rcvr method args [expected #f]) (define (tc/send form rcvr method args [expected #f])
(match (tc-expr rcvr) (define (do-check rcvr-type)
[(tc-result1: (Instance: (and c (Class: _ _ _ methods)))) (match rcvr-type
(match (tc-expr method) [(tc-result1: (Instance: (? Mu? type)))
[(tc-result1: (Value: (? symbol? s))) (do-check (ret (make-Instance (unfold type))))]
(let* ([ftype (cond [(assq s methods) => cadr] [(tc-result1: (Instance: (and c (Class: _ _ _ methods))))
[else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] (match (tc-expr method)
[retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)]) [(tc-result1: (Value: (? symbol? s)))
(add-typeof-expr form retval) (let* ([ftype (cond [(assq s methods) => cadr]
retval)] [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
[(tc-result1: t) (int-err "non-symbol methods not supported by Typed Racket: ~a" t)])] [retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)])
[(tc-result1: t) (tc-error/expr #:return (or expected (ret -Bottom)) "send: expected a class instance, got ~a" t)])) (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)]))
(do-check (tc-expr rcvr)))