1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
4
5; Topological sort on forms.
6
7; Puts top-level forms in the following order:
8;
9; (DEFINE X <literal>)
10; (DEFINE Z (LAMBDA ...))
11; ...everything else...
12;
13; Every (DEFINE W ...) for which W is never SET! is followed by all forms
14; (DEFINE V W).
15;
16; The procedure definitions are topologically sorted; whenever possible no
17; use of a variable occurs before its definition.
18;
19; This uses the FREE-VARIABLES field set by usage.scm.
20
21(define (sort-forms nodes)
22  (let ((table (make-name-table))
23	(procs '())
24	(literals '())
25	(aliases '())
26	(rest '()))
27    (for-each (lambda (node)
28		(let ((form (make-form node)))
29		  (if (define-node? node)
30		      (let ((name (node-form (cadr (node-form node))))
31			    (value (caddr (node-form node))))
32			(table-set! table name form)
33			(cond ((lambda-node? value)
34			       (set! procs (cons form procs)))
35			      ((name-node? value)
36			       (set! aliases (cons form aliases))
37			       (set! rest (cons form rest)))
38			      ((or (quote-node? value)
39				   (literal-node? value))
40			       (set! literals (cons form literals)))
41			      (else
42			       (set! rest (cons form rest)))))
43		      (set! rest (cons form rest)))))
44	      (reverse nodes))
45    (for-each (lambda (form)
46		(maybe-make-aliased form table))
47	      aliases)
48    (insert-aliases
49     (append literals
50	     (topologically-sort procs table)
51	     (filter form-unaliased? rest)))))
52
53(define (stuff-count s)
54  (apply + (map (lambda (s) (length (cdr s))) s)))
55
56; For (DEFINE A B) add the form to the list of B's aliases if B is defined
57; in the current package and never SET!.
58
59(define (maybe-make-aliased form table)
60  (let* ((value (caddr (node-form (form-node form))))
61	 (maker (table-ref table (node-form value))))
62    (if (and (node-ref value 'binding)
63	     maker
64	     (= 0 (usage-assignment-count
65		    (node-ref (cadr (node-form (form-node maker))) 'usage))))
66	(begin
67	  (set-form-aliases! maker (cons form (form-aliases maker)))
68	  (set-form-unaliased?! form #f)))))
69
70(define (topologically-sort forms table)
71  (apply append
72	 (strongly-connected-components
73	   forms
74	   (lambda (form)
75	     (filter (lambda (f)
76		       (and f
77			    (lambda-node? (caddr (node-form (form-node f))))))
78		     (map (lambda (name)
79			    (table-ref table (node-form name)))
80			  (form-free form))))
81	   form-temp
82	   set-form-temp!)))
83
84(define-record-type form :form
85  (really-make-form node free aliases unaliased?)
86  form?
87  (node form-node)
88  (aliases form-aliases set-form-aliases!)
89  (unaliased? form-unaliased? set-form-unaliased?!)
90  (free form-free set-form-free!)
91  (temp form-temp set-form-temp!))
92
93(define-record-discloser :form
94  (lambda (form)
95    (list 'form
96	  (let ((node (form-node form)))
97	    (if (define-node? node)
98		(node-form (cadr (node-form node)))
99		node)))))
100
101(define (make-form node)
102  (really-make-form node
103		    (map usage-name-node
104			 (node-ref node 'free-variables))
105		    '()		; aliases
106		    #t))	; unaliased?
107
108; (DEFINE A ...) is followed by all forms (DEFINE X A).
109
110(define (insert-aliases forms)
111  (let loop ((forms forms) (done '()))
112    (if (null? forms)
113	(reverse done)
114	(let ((form (car forms)))
115	  (loop (append (form-aliases form) (cdr forms))
116		(cons (form-node form) done))))))
117