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

Adding a correction that changes the strongly connected components calculation

Browse Source 
svn: r6785
This commit is contained in:
Kathy Gray 2007-07-02 01:14:51 +00:00
parent 9b96dbd211
commit 4bcf7111fb
7 changed files with 137 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/profj/build-info.ss
View File

@ -1323,7 +1323,8 @@
(append (map (lambda (iface-spec) (send type-recs get-class-record iface-spec)) ifaces)
iface-records))
(append (map (lambda (iface) (make-name (make-id (car iface) #f) (cdr iface) #f)) ifaces)
(map (lambda (iface) (make-name iface null #f)) iface-names)))))
(map (lambda (iface)
(if (name? iface) iface (make-name iface null #f))) iface-names)))))
;get-methods-need-implementing: (list method-record) -> (list method-record)
(define (get-methods-need-implementing methods)

4
collects/profj/comb-parsers/parser-units.scm
View File

@ -338,7 +338,7 @@
(define (new-class expr)
(choose ((sequence (new name O_PAREN C_PAREN) id "class instantiation")
(sequence (new name O_PAREN (comma-sep expr "arguments") C_PAREN) id "class instantiation"))
(sequence (new name O_PAREN (comma-sep expression "arguments") C_PAREN) id "class instantiation"))
"class instantiation"))
(define (new-array type-name expr)
@ -838,7 +838,7 @@
(assignment
(choose (identifier
(sequence (expression field-access-end) id)
(sequence (expression array-access-end) id))
(sequence (expression (array-access-end expression)) id))
"asignee")
assignment-ops expression)
(sequence (expression ++) id "unary mutation")

6
collects/profj/compile.ss
View File

@ -165,7 +165,8 @@
(unless (null? (check-list))
(check-defs (car (check-list)) level type-recs))
(remove-from-packages ast type-recs)
(order-cus (translate-program ast type-recs)
(reverse (translate-program ast type-recs))
#;(order-cus (translate-program ast type-recs)
type-recs))
(define (compile-to-ast port location type-recs file? level)
@ -194,7 +195,8 @@
(unless (null? (check-list))
(check-defs (car (check-list)) level type-recs))
(remove-from-packages ast type-recs)
(order-cus (translate-program ast type-recs) type-recs)))
(reverse (translate-program ast type-recs))
#;(order-cus (translate-program ast type-recs) type-recs)))
;compile-interactions: port location type-records level -> syntax
(define (compile-interactions port location type-recs level)

103
collects/profj/graph-scc.ss Normal file
View File

@ -0,0 +1,103 @@
(module graph-scc mzscheme
#;(require "ast.ss")
(provide get-scc)
(define (get-scc nodes get-successors for-each-node)
(letrec ([in-component (make-hash-table)]
[dpth-nums (make-hash-table)]
[root-of-node (make-hash-table)]
[counter 0]
[stack null]
[sccs null]
;node -> boolean
[visited?
(lambda (node)
(symbol? (hash-table-get in-component node #f)))]
;node -> boolean
[in-component?
(lambda (node)
(eq? 'true (hash-table-get in-component node #f)))]
;node node -> node
[min-root
(lambda (old-min new-node)
#;(printf "~a <= ~a, ~a" (hash-table-get dpth-nums old-min)
(hash-table-get dpth-nums
(hash-table-get root-of-node new-node)
(lambda () (add1 counter))) counter)
(if (<= (hash-table-get dpth-nums old-min)
(hash-table-get dpth-nums
(hash-table-get root-of-node new-node)
(add1 counter)))
old-min
new-node))]
;node -> void
[assign-depth-num
(lambda (node)
(unless (hash-table-get dpth-nums node #f)
(hash-table-put! dpth-nums node counter)
(set! counter (add1 counter))))]
[push! (lambda (v) (set! stack (cons v stack)))]
[pop! (lambda () (begin0 (car stack) (set! stack (cdr stack))))]
;visit: node -> void
[visit
(lambda (node)
#;(printf "visit of ~a~n" (def-name node))
(let ([root-v node])
(hash-table-put! root-of-node node root-v)
(hash-table-put! in-component node 'false)
(assign-depth-num node)
(push! node)
(for-each-node
(lambda (successor)
(unless (visited? successor) (visit successor))
#;(printf "finished visiting successor ~a on visit of ~a~n"
(def-name successor) (def-name node))
(unless (in-component? successor)
#;(printf "old-root-v ~a~n" (def-name root-v))
(set! root-v (min-root root-v successor))
#;(printf "new-root-v ~a~n" (def-name root-v))))
(get-successors node))
#;(printf "root-v ~a for visit of ~a~n" (def-name root-v)
(def-name node))
(hash-table-put! root-of-node node root-v)
(if (eq? root-v node)
(let loop ([w (pop!)] [scc null])
#;(printf "~a ~a ~n" w scc)
(hash-table-put! in-component w 'true)
(if (eq? w node)
(set! sccs (cons (cons w scc) sccs))
(loop (pop!) (cons w scc)))))))])
(for-each-node (lambda (node)
(set! counter 0)
(set! dpth-nums (make-hash-table))
(unless (visited? node) (visit node)))
nodes)
#;(printf "sccs: ~a~n" (map (lambda (scc)
(map def-name scc)) sccs))
sccs))
#;(define-struct node (name points-to)(make-inspector))
#;(define node-list
(list (make-node 'a '(b e))
(make-node 'b '(c))
(make-node 'c '(a d))
(make-node 'd '(b))
(make-node 'e '(f))
(make-node 'f '(e))))
#;(define (get-successors node)
(map (lambda (n)
(let loop ([nl node-list])
(if (eq? n (node-name (car nl)))
(car nl)
(loop (cdr nl)))))
(node-points-to node)))
)

1
collects/profj/name-utils.scm
View File

@ -5,6 +5,7 @@
(define (getter match-pattern replace-pattern)
(lambda (name)
(cond
[(symbol? name) name]
[(regexp-match match-pattern name) (regexp-replace replace-pattern name "")]
[else name])))

32
collects/profj/to-scheme.ss
View File

@ -2,6 +2,7 @@
(require "ast.ss"
"types.ss"
"name-utils.scm"
"graph-scc.ss"
"parameters.ss"
(lib "class.ss")
(lib "list.ss")
@ -250,7 +251,8 @@
(lambda (def)
(filter (lambda (x) x) (map find (def-uses def)))))
)
(get-strongly-connected-components defs for-each-def get-requires)))
(get-scc defs get-requires for-each)
#;(get-strongly-connected-components defs for-each-def get-requires)))
;get-strongly-connected-components: GRAPH (GRAPH (NODE -> void) -> void) (NODE -> (list NODE)) -> (list (list NODE))
(define (get-strongly-connected-components graph for-each-node get-connected-nodes)
@ -265,8 +267,7 @@
(in-current-cycle?
(lambda (n) (hash-table-get current-cycle n (lambda () #f))))
(current-cycle-memq
(lambda (nodes)
(ormap in-current-cycle? nodes)))
(lambda (nodes) (ormap in-current-cycle? nodes)))
(add-to-current-cycle
(lambda (n)
(set! cur-cycle-length (add1 cur-cycle-length))
@ -274,10 +275,15 @@
(retrieve-current-cycle
(lambda () (hash-table-map current-cycle (lambda (key v) key))))
;; componetize : NODE (list NODE) bool -> void
(componentize
(lambda (node successors member?)
(unless (already-in-cycle? node)
;(printf "componentize ~a ~a ~a~n" node successors member?)
(printf "componentize ~a ~a ~a~n"
(id-string (def-name node))
(map id-string (map def-name successors))
(map id-string (map def-name (retrieve-current-cycle)))
)
(let ((added? #f)
(cur-length cur-cycle-length)
(old-mark (hash-table-get marks node)))
@ -291,7 +297,10 @@
(eq? 'in-progress (hash-table-get marks successor)))
(componentize successor (get-connected-nodes successor) #f)))
successors)
;(printf "finished successors for ~a~n" node)
(printf "finished successors for ~a~n" (id-string (def-name node)))
(when (not (= cur-length cur-cycle-length))
(add-to-current-cycle node))
(if (or added? (= cur-length cur-cycle-length))
(hash-table-put! marks node old-mark)
(componentize node successors #f)))))))
@ -300,14 +309,21 @@
(for-each-node graph
(lambda (node)
;(hash-table-for-each marks (lambda (key val) (printf "~a -> ~a~n" (eq-hash-code key) val)))
;(printf "Working on ~a~n~n" (eq-hash-code node))
#;(hash-table-for-each
marks
(lambda (key val) (printf "~a -> ~a~n" (eq-hash-code key) val)))
#;(printf "Working on ~a~n~n" (eq-hash-code node))
#;(printf "node: ~a successors: ~a" (def-name node) (map def-name (get-connected-nodes node)))
(when (eq? (hash-table-get marks node) 'no-info)
(set! current-cycle (make-hash-table))
(add-to-current-cycle node)
(set! cur-cycle-length 0)
(printf "calling componetice ~a~n" (id-string (def-name node)))
(for-each (lambda (node) (componentize node (get-connected-nodes node) #f))
(get-connected-nodes node))
(set! strongly-connecteds (cons (retrieve-current-cycle) strongly-connecteds))
(set! strongly-connecteds
(cons (retrieve-current-cycle) strongly-connecteds))
(printf "~a~n~n" (map id-string (map def-name (car strongly-connecteds))))
(hash-table-for-each
current-cycle
(lambda (n v) (hash-table-put! marks n 'in-a-cycle))))))

1
collects/profj/tool.ss
View File

@ -635,6 +635,7 @@
(examples (if (testcase-ext?)
(list (send execute-types get-test-classes) null)
(find-examples compilation-units))))
(printf "ProfJ compilation complete~n")
(let ((name-to-require #f)
(tests-run? #f))
(let loop ((mods (order compilation-units))