blob: 25fdfcfbed38f40890551ec6ce8108554a962fb1 (
about) (
plain)
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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
;;; This is the main driver for the import / export routine
(define (import-export modules)
(walk-modules modules
(lambda () (add-module-to-symbol-table *module*)))
(walk-modules modules
(lambda () (init-module-structure)))
(import-export/fixpoint modules '#t)
(walk-modules modules (lambda () (check-missing-names)))
(when (memq 'import (dynamic *printers*))
(show-export-tables modules))
modules)
(define (import-export/interface modules)
(walk-modules modules
(lambda () (add-module-to-symbol-table *module*)))
(walk-modules modules
(lambda () (init-module-structure)))
(walk-modules modules
(lambda () (create-top-definitions)
(attach-fixities))))
(define (import-export/fixpoint modules initial-cycle?)
(setf *new-exports-found?* '#f)
(walk-modules modules
(lambda ()
(setf (module-fresh-exports *module*) '())
(when initial-cycle?
(create-top-definitions)
(attach-fixities)
(import-non-local))
(locally-import)
(locally-export)))
(when *new-exports-found?*
(import-export/fixpoint modules '#f)))
;;; This does the non-local importing from previously defined modules
(define (import-non-local)
(setf (module-imports *module*)
(process-non-local-imports (module-imports *module*))))
(define (process-non-local-imports imports)
(if (null? imports)
'()
(let* ((import (car imports)))
(with-slots import-decl (module mode specs renamings) import
(cond ((eq? *unit* (module-unit module))
(cons import (process-non-local-imports (cdr imports))))
((eq? mode 'all)
(import-all-entities module specs renamings import)
(process-non-local-imports (cdr imports)))
(else
(import-named-entities module specs renamings import)
(process-non-local-imports (cdr imports))))))))
(define (import-all-entities module hiding renamings import-decl)
(table-for-each
(lambda (name group)
(declare (ignore name))
(cond ((in-hiding-list? group hiding)
(setf hiding (remove-entity group hiding)))
(else
(import-group (rename-group group renamings) module))))
(module-export-table module))
(when (not (null? hiding))
(remember-context import-decl
(dolist (h hiding)
(signal-unused-hiding (entity-name h) (module-name module)))))
(find-unused-renamings renamings import-decl))
(define (import-named-entities mod specs renamings import-decl)
(dolist (entity specs)
(let ((group (locate-entity/export-table entity mod '#t)))
(when (not (eq? group 'error))
(setf group (rename-group group renamings))
(import-group group mod))))
(find-unused-renamings renamings import-decl))
;;; This takes a module and processes the import declarations, moving as
;;; many entities from the freshly exported components of other modules into
;;; the current module.
(define (locally-import)
(dolist (import (module-imports *module*))
(with-slots import-decl (module mode specs renamings) import
(if (eq? mode 'all)
(import-fresh-entities import module specs renamings)
(setf (import-decl-specs import)
(import-entities specs module renamings))))))
(define (import-fresh-entities import module hiding renamings)
(dolist (group (module-fresh-exports module))
(cond ((in-hiding-list? group hiding)
(setf hiding (remove-entity group hiding)))
(else
(import-group (rename-group group renamings) module))))
(setf (import-decl-specs import) hiding))
(define (import-entities entities module renamings)
(if (null? entities)
'()
(let ((group (locate-entity/export-table (car entities) module '#f)))
(cond ((eq? group 'not-found)
(cons (car entities)
(import-entities (cdr entities) module renamings)))
((eq? group 'error)
(import-entities (cdr entities) module renamings))
(else
(setf group (rename-group group renamings))
(import-group group module)
(import-entities (cdr entities) module renamings))))))
;;; This imports a group into *module*. module is the place the group is
;;; taken from.
(define (import-group group module)
(when (memq module (module-exported-modules *module*))
(export-group group))
(dolist (n-d group)
(insert-top-definition (tuple-2-1 n-d) (tuple-2-2 n-d))))
;;; This takes as yet unresolved exports and moves them to the export table.
(define (locally-export)
(setf (module-exports *module*)
(export-entities (module-exports *module*))))
(define (export-entities entities)
(if (null? entities)
'()
(let* ((entity (car entities))
(group (locate-entity entity)))
(cond ((eq? group 'error)
(export-entities (cdr entities)))
((eq? group 'not-found)
(cons entity (export-entities (cdr entities))))
(else
(export-group group)
(export-entities (cdr entities)))))))
;;; This moves a group into the export table. If this export is new,
;;; a flag is set.
(define (export-group group)
(let* ((export-table (module-export-table *module*))
(old-group (table-entry export-table (group-name group))))
(when (or (eq? old-group '#f)
(and (hidden-constructors? old-group)
(not (hidden-constructors? group))))
(setf (table-entry export-table (group-name group)) group)
(dolist (n-d group)
(setf (def-exported? (tuple-2-2 n-d)) '#t))
(push group (module-fresh-exports *module*))
(setf *new-exports-found?* '#t))))
(define (show-export-tables modules)
(walk-modules modules
(lambda ()
(format '#t "~%Exports from module ~A~%" *module-name*)
(let ((exports '()))
(table-for-each (lambda (key val)
(push (cons key val) exports))
(module-export-table *module*))
(setf exports (sort-list exports
(lambda (x y)
(string-ci<? (symbol->string (car x))
(symbol->string (car y))))))
(dolist (e exports)
(print-exported-group (car e) (group-definition (cdr e))
(cdr (cdr e))))))))
(define (print-exported-group name def extras)
(if (eq? (def-module def) *module-name*)
(format '#t " ")
(format '#t "*"))
(cond ((synonym? def)
(format '#t "type "))
((algdata? def)
(format '#t "data "))
((class? def)
(format '#t "class "))
(else
(format '#t " ")))
(format '#t "~A" name)
(when (not (eq? name (def-name def)))
(format '#t "[~A]" (def-name def)))
(when extras
(format '#t " (")
(print-exported-group-1 extras (algdata? def)))
(format '#t "~%"))
(define (print-exported-group-1 extras alg?)
(let* ((name (tuple-2-1 (car extras)))
(ns (symbol->string name))
(def (tuple-2-2 (car extras))))
(format '#t "~A" (if alg? (remove-con-prefix ns) ns))
(when (not (eq? name (def-name def)))
(let ((name1 (symbol->string (def-name def))))
(format '#t "[~A]" (if alg? (remove-con-prefix name1) name1))))
(if (null? (cdr extras))
(format '#t ")")
(begin
(format '#t ",")
(print-exported-group-1 (cdr extras) alg?)))))
|
