From 663e96afd6437bbb26866be1e8fbd9dfeb59582f Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 14 Mar 2014 16:47:11 -0400 Subject: [PATCH] Fix type->contract for recursive Name types Certain mutually recursive Name types would generate contracts that infinite loop when triggered. --- .../typed-racket/private/type-contract.rkt | 6 +++-- .../recursive-type-alias-terminates.rkt | 22 +++++++++++++++++++ 2 files changed, 26 insertions(+), 2 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/recursive-type-alias-terminates.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt index 719c4c5b98..8187227ac6 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -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 diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/recursive-type-alias-terminates.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/recursive-type-alias-terminates.rkt new file mode 100644 index 0000000000..299d590cc7 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/recursive-type-alias-terminates.rkt @@ -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))