From 304cdc24834b8aefcac72933b3722a9a578ed9a0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 May 2009 15:08:56 +0000 Subject: [PATCH] fix dropping cycles svn: r14811 original commit: ccca3b3df6d351ef6ee2f0158b8c7da4a3451b50 --- collects/profile/utils.ss | 32 ++------------------------------ 1 file changed, 2 insertions(+), 30 deletions(-) diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index b13fd88..944c59b 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -64,8 +64,9 @@ ;; remove visited and duplicates [next (remove-duplicates (remq* sorted next))] ;; leave only nodes with no other incoming edges + [seen (append next sorted)] ; important for cycles [next* (filter (lambda (node) - (andmap (lambda (e) (memq (edge-caller e) sorted)) + (andmap (lambda (e) (memq (edge-caller e) seen)) (node-callers node))) next)] ;; but if all nodes have other incoming edges, then there must be @@ -74,32 +75,3 @@ ;; apply sublevel [next (if sublevel (sublevel next) next)]) (loop next (append (reverse next) sorted)))))) -#| -(define-syntax-rule (letnodes [id ...] body ...) - (let ([id (make-node 'id #f '() 0 0 '() '())] ...) body ...)) -(define (X . -> . Y) - (let ([e (make-edge 0 X 0 Y 0)]) - (set-node-callers! Y (cons e (node-callers Y))) - (set-node-callees! X (cons e (node-callees X))))) -(letnodes [A B C] - (A . -> . B) - (B . -> . C) - (equal? (topological-sort A values) - (list A B C))) -(letnodes [A B C] - ;; check that a cycle doesn't lead to dropping nodes - (A . -> . B) - (A . -> . C) - (B . -> . A) - (B . -> . C) - (C . -> . A) - (C . -> . B) - (null? (remq* (topological-sort A values) (list A B C)))) -(letnodes [A B C D] - (A . -> . B) - (B . -> . C) - (C . -> . D) - (A . -> . D) - (equal? (topological-sort A values) - (list A B C D))) -|#