1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees
; Code to print out module dependencies in a format readable by the
; graph layout program AT&T DOT Release 1.0. (for information on DOT call
; the AT&T Software Technology Center Common Support Hotline (908) 582-7009)
; Follow link script up to the actual linking
;(load-configuration "scheme/interfaces.scm")
;(load-configuration "scheme/packages.scm")
;(flatload initial-structures)
;(load "build/initial.scm")
;
; Load this and run it
;(load "scheme/debug/graph.scm")
;(dependency-graph (initial-packages)
; (map structure-package (list scheme-level-1 scheme-level-0))
; "graph.dot")
;
; Run the graph layout program
; setenv SDE_LICENSE_FILE /pls/local/lib/DOT/LICENSE.dot
; /pls/local/lib/DOT/dot -Tps graph.dot -o graph.ps
; Returns a list of the packages in the initial system.
(define (initial-packages)
(map (lambda (p)
(structure-package (cdr p)))
(append (struct-list scheme
environments
module-system
ensures-loaded
packages
packages-internal)
(desirable-structures))))
; Write the dependency graph found by rooting from PACKAGES to FILENAME.
; Packages in the list IGNORE are ignored.
;
; Each configuration file's packages are done as a separate subgraph.
(define (dependency-graph packages ignore filename)
(call-with-output-file filename
(lambda (out)
(display prelude out)
(newline out)
(let ((subgraphs (do-next-package packages ignore '() ignore out)))
(for-each (lambda (sub)
(note-subgraph sub out))
subgraphs)
(display "}" out)
(newline out)))))
; Do the first not-yet-done package, returning the subgraphs if there are
; no packages left. TO-DO, DONE, and IGNORE are lists of packages.
; SUBGRAPHS is an a-list indexed by source-file-name.
(define (do-next-package to-do done subgraphs ignore out)
(let loop ((to-do to-do))
(if (null? to-do)
subgraphs
(let ((package (car to-do)))
(if (memq package done)
(loop (cdr to-do))
(do-package package (cdr to-do) (cons package done)
subgraphs ignore out))))))
; Find the correct subgraph, add PACKAGE to it, note any edges, and continue
; with the rest of the graph.
(define (do-package package to-do done subgraphs ignore out)
(let* ((source-file (package-file-name package))
(opens (map structure-package
((package-opens-thunk package))))
(old-subgraph (assq source-file subgraphs))
(subgraph (or old-subgraph
(list source-file))))
(set-cdr! subgraph (cons package (cdr subgraph)))
(do-edges package opens source-file ignore out)
(do-next-package (append opens to-do)
done
(if old-subgraph
subgraphs
(cons subgraph subgraphs))
ignore
out)))
; Add an edge from each package in OPENS to PACKAGE, provided that the
; two were defined in the same file.
(define (do-edges package opens source-file ignore out)
(let loop ((opens opens) (done ignore))
(if (not (null? opens))
(loop (cdr opens)
(let ((p (car opens)))
(if (or (memq p done)
(not (string=? source-file (package-file-name p))))
done
(begin
(note-edge p package out)
(cons p done))))))))
; Writing out the package name as a string (actually, its the name of
; the first of the package's clients).
(define (package-name package out)
(let ((clients (population->list (package-clients package))))
(write-char #\" out)
(display (structure-name (car clients)) out)
(write-char #\" out)))
; Header for DOT files
(define prelude
"digraph G {
orientation=landscape;
size =\"10,7.5\";
page =\"8.5,11\";
ratio =fill;")
; Writing out edges and subgraphs
(define (note-edge from to out)
(display " " out)
(package-name from out)
(display " -> " out)
(package-name to out)
(write-char #\; out)
(newline out))
(define (note-subgraph subgraph out)
(display " subgraph \"cluster_" out)
(display (car subgraph) out)
(display "\" { label=\"" out)
(display (car subgraph) out)
(display "\"; " out)
(for-each (lambda (p)
(package-name p out)
(display "; " out))
(cdr subgraph))
(display "}" out)
(newline out))
|
