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

Revert "adjust recursive-contract so that it terminates on cyclic values"

Browse Source 
This reverts commit 7728e062f4.
This commit is contained in:
Robby Findler 2014-07-03 21:33:11 -05:00
parent 822526a5a2
commit 0db4df1d33
2 changed files with 25 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
pkgs/racket-pkgs/racket-test/tests/racket/contract/recursive-contract.rkt
View File

@ -72,25 +72,4 @@
'(let () '(let ()
(struct doll (contents)) (struct doll (contents))
(letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))]) (letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))])
(contract doll-ctc2 (doll 4) 'pos 'neg)))) (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))))

82
racket/collects/racket/contract/private/base.rkt
View File

@ -115,9 +115,7 @@
"type must be one of #:impersonator, #:chaperone, or #:flat" "type must be one of #:impersonator, #:chaperone, or #:flat"
stx stx
type)])) type)]))
#`(#,maker '#,name (λ () #,arg) '#,local-name #`(#,maker '#,name (λ () #,arg) '#,local-name))
'uninitialized-non-cyclic-first-order
'uninitialized-rec-proj-field))
(syntax-case stx () (syntax-case stx ()
[(_ arg type) [(_ arg type)
(keyword? (syntax-e #'type)) (keyword? (syntax-e #'type))
@ -127,56 +125,28 @@
(define (force-recursive-contract ctc) (define (force-recursive-contract ctc)
(define current (recursive-contract-ctc ctc)) (define current (recursive-contract-ctc ctc))
(when (or (symbol? current) (not current)) (cond
(define thunk (recursive-contract-thunk ctc)) [(or (symbol? current) (not current))
(define old-name (recursive-contract-name ctc)) (define thunk (recursive-contract-thunk ctc))
(set-recursive-contract-name! ctc (or current '<recursive-contract>)) (define old-name (recursive-contract-name ctc))
(define forced-ctc (set-recursive-contract-name! ctc (or current '<recursive-contract>))
(cond (define forced-ctc
[(flat-recursive-contract? ctc) (cond
(coerce-flat-contract 'recursive-contract (thunk))] [(flat-recursive-contract? ctc)
[(chaperone-recursive-contract? ctc) (coerce-flat-contract 'recursive-contract (thunk))]
(coerce-chaperone-contract 'recursive-contract (thunk))] [(chaperone-recursive-contract? ctc)
[(impersonator-recursive-contract? ctc) (coerce-chaperone-contract 'recursive-contract (thunk))]
(coerce-contract 'recursive-contract (thunk))])) [(impersonator-recursive-contract? ctc)
(define cm-key (box #f)) (coerce-contract 'recursive-contract (thunk))]))
(define orig-projection (contract-projection forced-ctc)) (set-recursive-contract-ctc! ctc forced-ctc)
(define ((wrapper-projection blame) val) (set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc))
(cond (cddr old-name)))
[(continuation-mark-set-first #f cm-key) forced-ctc]
=> [else current]))
(λ (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)))))
(define ((recursive-contract-projection ctc) blame) (define ((recursive-contract-projection ctc) blame)
(force-recursive-contract ctc) (define r-ctc (force-recursive-contract ctc))
(define f (recursive-contract-non-cyclic-projection ctc)) (define f (contract-projection r-ctc))
(define blame-known (blame-add-context blame #f)) (define blame-known (blame-add-context blame #f))
(λ (val) (λ (val)
((f blame-known) val))) ((f blame-known) val)))
@ -187,14 +157,10 @@
(recursive-contract-thunk that)))) (recursive-contract-thunk that))))
(define ((recursive-contract-first-order ctc) val) (define ((recursive-contract-first-order ctc) val)
(force-recursive-contract ctc) (contract-first-order-passes? (force-recursive-contract ctc)
((recursive-contract-non-cyclic-first-order ctc) val)) val))
(struct recursive-contract ([name #:mutable] (struct recursive-contract ([name #:mutable] thunk [ctc #:mutable]))
thunk
[ctc #:mutable]
[non-cyclic-first-order #:mutable]
[non-cyclic-projection #:mutable]))
(struct flat-recursive-contract recursive-contract () (struct flat-recursive-contract recursive-contract ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc