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
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Topological sort on forms.
; Puts top-level forms in the following order:
;
; (DEFINE X <literal>)
; (DEFINE Z (LAMBDA ...))
; ...everything else...
;
; Every (DEFINE W ...) for which W is never SET! is followed by all forms
; (DEFINE V W).
;
; The procedure definitions are topologically sorted; whenever possible no
; use of a variable occurs before its definition.
;
; This uses the FREE-VARIABLES field set by usage.scm.
(define (sort-forms nodes)
(let ((table (make-name-table))
(procs '())
(literals '())
(aliases '())
(rest '()))
(for-each (lambda (node)
(let ((form (make-form node)))
(if (define-node? node)
(let ((name (node-form (cadr (node-form node))))
(value (caddr (node-form node))))
(table-set! table name form)
(cond ((lambda-node? value)
(set! procs (cons form procs)))
((name-node? value)
(set! aliases (cons form aliases))
(set! rest (cons form rest)))
((or (quote-node? value)
(literal-node? value))
(set! literals (cons form literals)))
(else
(set! rest (cons form rest)))))
(set! rest (cons form rest)))))
(reverse nodes))
(for-each (lambda (form)
(maybe-make-aliased form table))
aliases)
(insert-aliases
(append literals
(topologically-sort procs table)
(filter form-unaliased? rest)))))
(define (stuff-count s)
(apply + (map (lambda (s) (length (cdr s))) s)))
; For (DEFINE A B) add the form to the list of B's aliases if B is defined
; in the current package and never SET!.
(define (maybe-make-aliased form table)
(let* ((value (caddr (node-form (form-node form))))
(maker (table-ref table (node-form value))))
(if (and (node-ref value 'binding)
maker
(= 0 (usage-assignment-count
(node-ref (cadr (node-form (form-node maker))) 'usage))))
(begin
(set-form-aliases! maker (cons form (form-aliases maker)))
(set-form-unaliased?! form #f)))))
(define (topologically-sort forms table)
(apply append
(strongly-connected-components
forms
(lambda (form)
(filter (lambda (f)
(and f
(lambda-node? (caddr (node-form (form-node f))))))
(map (lambda (name)
(table-ref table (node-form name)))
(form-free form))))
form-temp
set-form-temp!)))
(define-record-type form :form
(really-make-form node free aliases unaliased?)
form?
(node form-node)
(aliases form-aliases set-form-aliases!)
(unaliased? form-unaliased? set-form-unaliased?!)
(free form-free set-form-free!)
(temp form-temp set-form-temp!))
(define-record-discloser :form
(lambda (form)
(list 'form
(let ((node (form-node form)))
(if (define-node? node)
(node-form (cadr (node-form node)))
node)))))
(define (make-form node)
(really-make-form node
(map usage-name-node
(node-ref node 'free-variables))
'() ; aliases
#t)) ; unaliased?
; (DEFINE A ...) is followed by all forms (DEFINE X A).
(define (insert-aliases forms)
(let loop ((forms forms) (done '()))
(if (null? forms)
(reverse done)
(let ((form (car forms)))
(loop (append (form-aliases form) (cdr forms))
(cons (form-node form) done))))))
|
