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
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Scanning structures and processing package clauses.
; Utility for compile-structures (link/link.scm) and
; ensure-loaded (env/load-package.scm).
;
; Returns a list of all packages reachable from STRUCTS that answer true to
; INCLUDE-THIS-PACKAGE?.
(define (collect-packages structs include-this-package?)
(let ((package-seen '())
(structure-seen '())
(packages '()))
(letrec ((recur
(lambda (structure)
(if (not (memq structure structure-seen))
(begin
(set! structure-seen (cons structure structure-seen))
(let ((package (structure-package structure)))
(if (not (memq package package-seen))
(begin
(set! package-seen (cons package package-seen))
(if (include-this-package? package)
(begin
(for-each recur (package-opens package))
(for-each (lambda (name+struct)
(recur (cdr name+struct)))
(package-accesses package))
(set! packages (cons package packages))))))))))))
(for-each recur structs)
(reverse packages))))
; Walk through PACKAGE's clauses to find the source code. The relevent
; clauses are:
; (file name ...)
; (begin form ...)
; (define-all-operators)
; (usual-transforms)
;
; Returns a list of pairs (file . (node1 node2 ...)), a list of names
; of standard transforms, and a boolean value which is true if the package
; is to include definitions of all primitives.
(define (package-source package)
(let* ((config-file (package-file-name package))
(dir (if config-file
(file-name-directory config-file)
#f)))
(fold->3 (lambda (clause stuff transforms primitives?)
(case (car clause)
((files)
(values (read-files (cdr clause) stuff dir package)
transforms
primitives?))
((begin)
(values (cons (cons config-file (cdr clause))
stuff)
transforms
primitives?))
((integrate)
(set-package-integrate?! package
(or (null? (cdr clause))
(cadr clause)))
(values stuff transforms primitives?))
((optimize)
(values stuff transforms primitives?))
((define-all-operators)
(values stuff transforms #t))
((usual-transforms)
(values stuff
(append (cdr clause) transforms)
primitives?))
(else
(error "unrecognized define-structure keyword"
clause))))
(reverse (package-clauses package))
'() '() #f)))
; Also prints out the filenames (courtesy of READ-FORMS).
(define (read-files all-files stuff dir package)
(force-output (current-output-port)) ; just to be nice
(fold (lambda (filespec stuff)
(let ((file (namestring filespec
dir
*scheme-file-type*)))
(display #\space (current-noise-port))
(cons (cons file (read-forms file package))
stuff)))
(reverse all-files)
stuff))
(define (package-optimizer-names package)
(if (package-integrate? package)
(let ((opts (apply append
(map cdr (filter (lambda (clause)
(eq? (car clause) 'optimize))
(package-clauses package))))))
(reduce (lambda (name opts)
(if (memq name opts)
opts
(cons name opts)))
opts
'()))
'()))
(define (check-structure structure)
(let ((undefined '()))
(for-each-export
(lambda (name want-type binding)
(if (binding? binding)
(let ((have-type (binding-type binding)))
(if (not (compatible-types? have-type want-type))
(warn "Type in interface doesn't match binding"
name
`(binding: ,(type->sexp have-type #t))
`(interface: ,(type->sexp want-type #t))
structure)))
(set! undefined (cons name undefined))))
structure)
(if (not (null? undefined))
(warn "Structure has undefined exports"
structure
undefined))))
|
