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; Scanning structures and processing package clauses.
6
7; Utility for compile-structures (link/link.scm) and
8; ensure-loaded (env/load-package.scm).
9;
10; Returns a list of all packages reachable from STRUCTS that answer true to
11; INCLUDE-THIS-PACKAGE?.
12
13(define (collect-packages structs include-this-package?)
14  (let ((package-seen '())
15	(structure-seen '())
16	(packages '()))
17    (letrec ((recur
18	      (lambda (structure visited)
19		(if (memq (structure-package structure) visited)
20		    (warning 'collect-packages "cycle in structures dependencies"
21			     structure visited))
22		(if (not (memq structure structure-seen))
23		    (begin
24		      (set! structure-seen (cons structure structure-seen))
25		      (let ((package (structure-package structure)))
26			(if (not (memq package package-seen))
27			    (begin
28			      (set! package-seen (cons package package-seen))
29			      (if (include-this-package? package)
30				  (let ((visited (cons package visited)))
31				    (for-each (lambda (struct)
32						(recur struct visited))
33					      (package-opens package))
34				    (for-each (lambda (name+struct)
35						(recur (cdr name+struct) visited))
36					      (package-accesses package))
37				    (set! packages (cons package packages))))))))))))
38      (for-each (lambda (struct)
39		  (recur struct '()))
40		structs)
41      (reverse packages))))
42
43; Walk through PACKAGE's clauses to find the source code.  The relevant
44; clauses are:
45;   (files name ...)
46;   (begin form ...)
47;   (define-all-operators)
48;   (usual-transforms name ...)
49;
50; Returns a list of pairs (file . (node1 node2 ...)), a list of names
51; of standard transforms, and a boolean value which is true if the package
52; is to include definitions of all primitives.
53
54(define (package-source package)
55  (let* ((config-file (package-file-name package))
56	 (dir (if config-file
57		  (file-name-directory config-file)
58		  #f)))
59    (call-with-values
60	(lambda ()
61	  (fold->3 (lambda (clause stuff transforms primitives?)
62		     (case (car clause)
63		       ((files)
64			(values (read-files (cdr clause) stuff dir package)
65				transforms
66				primitives?))
67		       ((begin)
68			(values (cons (cons config-file (cdr clause))
69				      stuff)
70				transforms
71				primitives?))
72		       ((integrate)
73			(set-package-integrate?! package
74						 (or (null? (cdr clause))
75						     (cadr clause)))
76			(values stuff transforms primitives?))
77		       ((optimize)
78			(values stuff transforms primitives?))
79		       ((define-all-operators)
80			(values stuff transforms #t))
81		       ((usual-transforms)
82			(values stuff
83				(append (reverse (cdr clause)) transforms)
84				primitives?))
85		       ((reader)
86			(let ((r (force (comp-env-macro-eval (package->environment package)))))
87			  (set-package-reader! package ((car r) (cadr clause) (cdr r))))
88			(values stuff transforms primitives?))
89		       (else
90			(assertion-violation 'package-source
91					     "unrecognized define-structure keyword"
92					     clause))))
93		   (package-clauses package)
94		   '() '() #f))
95      (lambda (stuff transforms primitives?)
96	(values (reverse stuff)
97		(reverse transforms)
98		primitives?)))))
99
100; Also prints out the filenames (courtesy of READ-FORMS).
101
102(define (read-files all-files stuff dir package)
103  (force-output (current-output-port))		; just to be nice
104  (fold (lambda (filespec stuff)
105	  (let ((file (namestring filespec
106				  dir
107				  *scheme-file-type*)))
108	    (display #\space (current-noise-port))
109	    (cons (cons file (read-forms file package #f))
110		  stuff)))
111	all-files
112	stuff))
113
114(define (package-optimizer-names package)
115  (if (package-integrate? package)
116      (let ((opts (apply append
117			 (map cdr (filter (lambda (clause)
118					    (eq? (car clause) 'optimize))
119					  (package-clauses package))))))
120	(reduce (lambda (name opts)
121		  (if (memq name opts)
122		      opts
123		      (cons name opts)))
124		opts
125		'()))
126      '()))
127
128(define (check-structure structure)
129  (let ((undefined '()))
130    (for-each-export
131         (lambda (name want-type binding)
132	   (if (binding? binding)
133	       (let ((have-type (binding-type binding)))
134		 (if (not (compatible-types? have-type want-type))
135		     (warning 'check-structure
136			      "Type in interface doesn't match binding"
137			      name
138			      `(binding: ,(type->sexp have-type #t))
139			      `(interface: ,(type->sexp want-type #t))
140			      structure)))
141	       (set! undefined (cons name undefined))))
142	 structure)
143    (if (not (null? undefined))
144	(warning 'check-structure
145		 "Structure has undefined exports"
146		 structure
147		 undefined))))
148
149