diff --git a/collects/tests/typed-racket/succeed/pr13412.rkt b/collects/tests/typed-racket/succeed/pr13412.rkt new file mode 100644 index 00000000..387e3283 --- /dev/null +++ b/collects/tests/typed-racket/succeed/pr13412.rkt @@ -0,0 +1,12 @@ +#lang typed/racket + +(define-type (Tree A) (U (Listof A) (node A))) +(struct: (A) node ([val : A] + [left : (Tree A)] + [right : (Tree A)])) + +(: tree-set (All (A) (A (Tree A) -> (Tree A)))) +(define (tree-set y t) + (cond [(node? t) (node y (node-left t) (node-right t))] + [else (list y)])) + diff --git a/collects/typed-racket/types/current-seen.rkt b/collects/typed-racket/types/current-seen.rkt new file mode 100644 index 00000000..2268ab75 --- /dev/null +++ b/collects/typed-racket/types/current-seen.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require "../utils/utils.rkt") +(require (rep type-rep)) + +(provide (all-defined-out)) + +(define current-seen (make-parameter null)) +(define (currently-subtyping?) (not (null? (current-seen)))) + +(define (seen-before s t) (cons (Type-seq s) (Type-seq t))) +(define (remember s t A) (cons (seen-before s t) A)) +(define (seen? s t) (member (seen-before s t) (current-seen))) + diff --git a/collects/typed-racket/types/resolve.rkt b/collects/typed-racket/types/resolve.rkt index e1be521e..11d0a95b 100644 --- a/collects/typed-racket/types/resolve.rkt +++ b/collects/typed-racket/types/resolve.rkt @@ -4,7 +4,7 @@ (require (rep type-rep rep-utils free-variance) (env type-name-env) (utils tc-utils) - (types utils) + (types utils current-seen) racket/match racket/contract racket/format) @@ -82,7 +82,7 @@ [(App: r r* s) (resolve-app r r* s)] [(Name: _) (resolve-name t)])]) - (when r* + (when (and r* (not (currently-subtyping?))) (hash-set! resolver-cache seq r*)) r*))) diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 8770fe09..80b88c4b 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -2,7 +2,7 @@ (require (except-in "../utils/utils.rkt" infer) (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) - (types utils resolve base-abbrev numeric-tower substitute) + (types utils resolve base-abbrev numeric-tower substitute current-seen) (env type-name-env) racket/match unstable/match racket/function @@ -24,14 +24,6 @@ (syntax-rules () [(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))])) -;; data structures for remembering things on recursive calls -(define (empty-set) '()) - -(define current-seen (make-parameter (empty-set))) - -(define (seen-before s t) (cons (Type-seq s) (Type-seq t))) -(define (remember s t A) (cons (seen-before s t) A)) -(define (seen? s t) (member (seen-before s t) (current-seen))) (define subtype-cache (make-hash)) (define (cache-types s t) @@ -54,7 +46,8 @@ (define result (handle-failure (and (subtype* (current-seen) s t) #t))) ;(printf "subtype cache miss ~a ~a\n" s t) result) - (hash-ref! subtype-cache k new-val)) + ((if (currently-subtyping?) hash-ref hash-ref!) + subtype-cache k new-val)) ;; are all the s's subtypes of all the t's? ;; [type] [type] -> boolean @@ -162,7 +155,7 @@ (define (subtypes/varargs args dom rst) (with-handlers ([exn:subtype? (lambda _ #f)]) - (subtypes*/varargs (empty-set) args dom rst))) + (subtypes*/varargs null args dom rst))) (define (subtypes*/varargs A0 argtys dom rst) (let loop-varargs ([dom dom] [argtys argtys] [A A0])