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

Revert "change the strategy for recursive-contract's knot tying"

Browse Source 
This reverts commit 2a1c8a78a5.

something goes wrong with large recursive nests with this commit
This commit is contained in:
Robby Findler 2018-04-27 14:43:38 -05:00
parent 53ffd28e0f
commit ef8101bde3
3 changed files with 27 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -111,7 +111,7 @@
(for ([i (in-range 100)])
(void (vector-ref v 0)))
counter)
3)
2)
(test/spec-passed/result
'recursive-contract-not-too-slow

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

@ -156,7 +156,6 @@
#`(#,maker '#,stx
(λ () #,arg)
'#,(syntax-local-infer-name stx)
(make-parameter #f)
#,(if list-contract? #'#t #'#f)
#,@(if (equal? (syntax-e type) '#:flat)
(list (if extra-delay? #'#t #'#f))
@ -205,27 +204,32 @@
[else current]))
(define (recursive-contract-late-neg-projection ctc)
(define p (recursive-contract-param ctc))
(λ (blame)
(cond
[(p) => (λ (b) (λ (val neg-party) ((unbox b) val neg-party)))]
[else
(cond
[(recursive-contract-list-contract? ctc)
(λ (blame)
(define r-ctc (force-recursive-contract ctc))
(define f (get/build-late-neg-projection r-ctc))
(define blame-known (blame-add-context blame #f))
(define b (box 'uninitialized-recursive-contract))
(define func (parameterize ([p b]) (f blame-known)))
(set-box! b func)
(cond
[(recursive-contract-list-contract? ctc)
(λ (val neg-party)
(unless (list? val)
(raise-blame-error blame-known #:missing-party neg-party
val
'(expected: "list?" given: "~e")
val))
(func val neg-party))]
[else func])])))
(define f-blame-known (make-thread-cell #f))
(λ (val neg-party)
(unless (list? val)
(raise-blame-error blame-known #:missing-party neg-party
val
'(expected: "list?" given: "~e")
val))
(unless (thread-cell-ref f-blame-known)
(thread-cell-set! f-blame-known (f blame-known)))
((thread-cell-ref f-blame-known) val neg-party)))]
[else
(λ (blame)
(define r-ctc (force-recursive-contract ctc))
(define f (get/build-late-neg-projection r-ctc))
(define blame-known (blame-add-context blame #f))
(define f-blame-known (make-thread-cell #f))
(λ (val neg-party)
(unless (thread-cell-ref f-blame-known)
(thread-cell-set! f-blame-known (f blame-known)))
((thread-cell-ref f-blame-known) val neg-party)))]))
(define (flat-recursive-contract-late-neg-projection ctc)
(cond
@ -269,7 +273,7 @@
(force-recursive-contract ctc)
(contract-random-generate/choose (recursive-contract-ctc ctc) (- fuel 1))])))
(struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] param list-contract?)
(struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] list-contract?)
#:property prop:recursive-contract (λ (this)
(force-recursive-contract this)
(recursive-contract-ctc this)))

4
racket/collects/racket/contract/private/object.rkt
View File

@ -65,9 +65,9 @@
(define mtd-ctcs (object-contract-method-ctcs ctc))
(λ (blame)
(define p-app
(make-wrapper-object blame mtds mtd-ctcs flds fld-ctcs))
(make-wrapper-object blame mtds mtd-ctcs))
(λ (val neg-party)
(p-app ctc val neg-party))))
(p-app ctc val neg-party flds fld-ctcs))))
#:name
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc)