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

fixed bug in the cycle detection code in test-->

Browse Source 
svn: r14002
This commit is contained in:
Robby Findler 2009-03-07 13:38:41 +00:00
parent 7d50018356
commit 37cde560a9
2 changed files with 60 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/redex/private/reduction-semantics.ss
View File

@ -1730,18 +1730,19 @@
(define (apply-reduction-relation*/cycle? reductions exp) (define (apply-reduction-relation*/cycle? reductions exp)
(let ([answers (make-hash)] (let ([answers (make-hash)]
[cycle? #f] [cycle? #f])
[cycles (make-hash)]) (let loop ([exp exp]
(let loop ([exp exp]) [path (make-immutable-hash '())])
(cond (cond
[(hash-ref cycles exp #f) [(hash-ref path exp #f)
(set! cycle? #t)] (set! cycle? #t)]
[else [else
(hash-set! cycles exp #t)
(let ([nexts (apply-reduction-relation reductions exp)]) (let ([nexts (apply-reduction-relation reductions exp)])
(cond (cond
[(null? nexts) (hash-set! answers exp #t)] [(null? nexts) (hash-set! answers exp #t)]
[else (for-each loop nexts)]))])) [else (for-each
(λ (next) (loop next (hash-set path exp #t)))
nexts)]))]))
(values (sort (hash-map answers (λ (x y) x)) (values (sort (hash-map answers (λ (x y) x))
string<=? string<=?
#:key (λ (x) (format "~s" x))) #:key (λ (x) (format "~s" x)))

53
collects/redex/private/tl-test.ss
View File

@ -1393,4 +1393,57 @@
(test (sort (covered-cases c) <) (test (sort (covered-cases c) <)
'(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1))))) '(("shortcut" . 1) ("side-condition" . 2) ("unnamed" . 1)))))
;
;
;
;
; ;;;
; ;; ;; ; ;; ;;
; ;; ;; ; ;; ;;
; ;;;;; ;;; ;;; ;;;;; ;; ;;; ;;;; ;;;;
; ;; ;; ;; ;; ; ;; ;;;;;;;; ;; ;;; ;; ; ;; ;;
; ;; ;;;;; ;;; ;; ;;; ;; ; ;; ;; ;; ;;
; ;; ;; ;; ;; ;;; ;; ;;;; ;; ;; ;;
; ;; ;; ; ; ;; ;; ;; ;; ;; ;; ; ;; ;;
; ;;;; ;;; ;;; ;;;; ; ;;;;; ;; ;;;; ;;;;
;
;
;
(define-syntax-rule
(capture-output arg1 args ...)
(let ([p (open-output-string)])
(parameterize ([current-output-port p]
[current-error-port p])
arg1 args ...)
(get-output-string p)))
(let ()
(define red (reduction-relation empty-language (--> 1 2)))
(test (capture-output (test--> red 1 2) (test-results))
"One test passed.\n")
(test (capture-output (test--> red 2 3) (test-results))
#rx"FAILED tl-test.ss:[0-9.]+\nexpected: 3\n actual: 2\n1 test failed \\(out of 1 total\\).\n"))
(let ()
(define red-share (reduction-relation
empty-language
(--> a b)
(--> a c)
(--> c d)
(--> b d)))
(test (capture-output (test--> red-share (term a) (term d)) (test-results))
"One test passed.\n"))
(let ()
(define red-cycle (reduction-relation
empty-language
(--> a a)))
(test (capture-output (test--> red-cycle #:cycles-ok (term a)) (test-results))
"One test passed.\n")
(test (capture-output (test--> red-cycle (term a)) (test-results))
#rx"FAILED tl-test.ss:[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n"))
(print-tests-passed 'tl-test.ss)) (print-tests-passed 'tl-test.ss))