Fix type->contract for recursive Name types

Certain mutually recursive Name types would generate
contracts that infinite loop when triggered.
This commit is contained in:
Asumu Takikawa 2014-03-14 16:47:11 -04:00
parent d37be5f6c5
commit 663e96afd6
2 changed files with 26 additions and 2 deletions

View File

@ -251,12 +251,14 @@
(recursive-sc-use both-dep)))))
(define resolved-name (resolve-once type))
(define resolved-deps
(map (λ (dep) (lookup-type-alias dep values)) dep-ids))
(for/list ([dep (in-list dep-ids)])
(resolve-once (lookup-type-alias dep values))))
;; resolved-deps->scs : (U 'untyped 'typed 'both)
;; -> (Listof Static-Contract)
(define (resolved-deps->scs typed-side)
(for/list ([resolved-dep resolved-deps])
(for/list ([resolved-dep (in-list resolved-deps)]
[dep (in-list deps)])
(loop resolved-dep typed-side rv)))
;; Now actually generate the static contracts

View File

@ -0,0 +1,22 @@
#lang racket/load
;; Test that contracts for mutually recursive class types do not
;; cause infinite loops when they execute.
(module a typed/racket
(define-type X%
(Class [m (-> (Instance Y%) String)]))
(define-type Y%
(Class [m (-> (Instance X%) Any)]))
(: x X%)
(define x (class object%
(super-new)
(define/public (m y) "foo")))
(: y Y%)
(define y (class object%
(super-new)
(define/public (m x) 0)))
(provide x y))
(require 'a)
(send (new x) m (new y))