From 0db4df1d330c3785558dfff776285eae87a98be0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 3 Jul 2014 21:33:11 -0500 Subject: [PATCH] Revert "adjust recursive-contract so that it terminates on cyclic values" This reverts commit 7728e062f481a5bce42c663d91e6e0919d706e62. --- .../racket/contract/recursive-contract.rkt | 23 +----- .../collects/racket/contract/private/base.rkt | 82 ++++++------------- 2 files changed, 25 insertions(+), 80 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/recursive-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/recursive-contract.rkt index 4497613108..523c688ee2 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/recursive-contract.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/recursive-contract.rkt @@ -72,25 +72,4 @@ '(let () (struct doll (contents)) (letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))]) - (contract doll-ctc2 (doll 4) 'pos 'neg)))) - - (test/spec-passed - 'recursive-contract12 - '(let () - (define c - (recursive-contract - (or/c #f (cons/c c c)) - #:flat)) - (define ph (make-placeholder #f)) - (placeholder-set! ph (cons ph ph)) - (contract c (make-reader-graph ph) 'pos 'neg) - (void))) - - (test/spec-passed - 'recursive-contract13 - '(let () - (define c - (recursive-contract - (or/c #f (cons/c c c)))) - (define x (cons #f #f)) - (contract c (cons (cons x x) (cons x x)) 'pos 'neg)))) + (contract doll-ctc2 (doll 4) 'pos 'neg))))) diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index 6d176d30fc..f01eb9f403 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -115,9 +115,7 @@ "type must be one of #:impersonator, #:chaperone, or #:flat" stx type)])) - #`(#,maker '#,name (λ () #,arg) '#,local-name - 'uninitialized-non-cyclic-first-order - 'uninitialized-rec-proj-field)) + #`(#,maker '#,name (λ () #,arg) '#,local-name)) (syntax-case stx () [(_ arg type) (keyword? (syntax-e #'type)) @@ -127,56 +125,28 @@ (define (force-recursive-contract ctc) (define current (recursive-contract-ctc ctc)) - (when (or (symbol? current) (not current)) - (define thunk (recursive-contract-thunk ctc)) - (define old-name (recursive-contract-name ctc)) - (set-recursive-contract-name! ctc (or current ')) - (define forced-ctc - (cond - [(flat-recursive-contract? ctc) - (coerce-flat-contract 'recursive-contract (thunk))] - [(chaperone-recursive-contract? ctc) - (coerce-chaperone-contract 'recursive-contract (thunk))] - [(impersonator-recursive-contract? ctc) - (coerce-contract 'recursive-contract (thunk))])) - (define cm-key (box #f)) - (define orig-projection (contract-projection forced-ctc)) - (define ((wrapper-projection blame) val) - (cond - [(continuation-mark-set-first #f cm-key) - => - (λ (ht) - (cond - [(hash-ref ht val #f) val] - [else - (hash-set! ht val #t) - ((orig-projection blame) val)]))] - [else - (with-continuation-mark cm-key (make-hasheq) - ((orig-projection blame) val))])) - (define orig-first-order (contract-first-order forced-ctc)) - (define (wrapper-first-order val) - (cond - [(continuation-mark-set-first #f cm-key) - => - (λ (ht) - (cond - [(hash-ref ht val #f) #t] - [else - (hash-set! ht val #t) - (orig-first-order val)]))] - [else - (with-continuation-mark cm-key (make-hasheq) - (orig-first-order val))])) - (set-recursive-contract-ctc! ctc forced-ctc) - (set-recursive-contract-non-cyclic-projection! ctc wrapper-projection) - (set-recursive-contract-non-cyclic-first-order! ctc wrapper-first-order) - (set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc)) - (cddr old-name))))) + (cond + [(or (symbol? current) (not current)) + (define thunk (recursive-contract-thunk ctc)) + (define old-name (recursive-contract-name ctc)) + (set-recursive-contract-name! ctc (or current ')) + (define forced-ctc + (cond + [(flat-recursive-contract? ctc) + (coerce-flat-contract 'recursive-contract (thunk))] + [(chaperone-recursive-contract? ctc) + (coerce-chaperone-contract 'recursive-contract (thunk))] + [(impersonator-recursive-contract? ctc) + (coerce-contract 'recursive-contract (thunk))])) + (set-recursive-contract-ctc! ctc forced-ctc) + (set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc)) + (cddr old-name))) + forced-ctc] + [else current])) (define ((recursive-contract-projection ctc) blame) - (force-recursive-contract ctc) - (define f (recursive-contract-non-cyclic-projection ctc)) + (define r-ctc (force-recursive-contract ctc)) + (define f (contract-projection r-ctc)) (define blame-known (blame-add-context blame #f)) (λ (val) ((f blame-known) val))) @@ -187,14 +157,10 @@ (recursive-contract-thunk that)))) (define ((recursive-contract-first-order ctc) val) - (force-recursive-contract ctc) - ((recursive-contract-non-cyclic-first-order ctc) val)) + (contract-first-order-passes? (force-recursive-contract ctc) + val)) -(struct recursive-contract ([name #:mutable] - thunk - [ctc #:mutable] - [non-cyclic-first-order #:mutable] - [non-cyclic-projection #:mutable])) +(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable])) (struct flat-recursive-contract recursive-contract () #:property prop:custom-write custom-write-property-proc