blob: 5198c0c6c94cc6ae924a7c05708313181faffc4c (
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
|
;;; This initializes the module ast structures.
;;; This requires that the module table be created and updated with new
;;; modules first. *unit* must also be defined.
;;; Things initialized there:
;;; all tables in the module structure
;;; the module slot of all import declarations and entity-modules
;;; The import Prelude is added when necessary
;;; Empty export lists are explicated
(define (init-module-structure)
(when (not (eq? (module-type *module*) 'extension))
;; If this is an extension, the incremental compiler has already
;; filled in the compilation unit.
(setf (module-unit *module*) *unit*))
;;; This processes the annotations. Annotations used at the top
;;; level of the module:
;;; {-#PRELUDE#-} : this contains definitions in the Haskell prelude
(setf (module-prelude? *module*) '#f)
(setf (module-interface-codefile *module*) '())
(dolist (a (module-annotations *module*))
(when (annotation-value? a)
(let ((name (annotation-value-name a)))
(cond ((eq? name '|Prelude|)
(setf (module-prelude? *module*) '#t))))))
(cond ((eq? (module-type *module*) 'interface)
(setf (module-exported-modules *module*) (list *module*))
(process-interface-imports *module*))
((eq? (module-type *module*) 'standard)
(init-standard-module))))
(define (init-standard-module)
(let ((seen-prelude? '#f))
(dolist (import (module-imports *module*))
(let* ((name (import-decl-module-name import))
(imported-mod (locate-module name)))
(when (eq? name '|Prelude|)
(setf seen-prelude? '#t))
(if (eq? imported-mod '#f)
(signal-undefined-module-import name)
(setf (import-decl-module import) imported-mod))
(when (eq? name *module-name*)
(signal-self-import name))))
(when (null? (module-exports *module*))
(setf (module-exports *module*)
(list (make entity-module (name *module-name*)
(module *module*)))))
(when (not seen-prelude?)
(let ((prelude (locate-module '|Prelude|)))
(cond ((eq? prelude '#f)
(signal-missing-prelude))
((module-prelude? *module*)
(setf (module-uses-standard-prelude? *module*) '#f)
(add-imported-module prelude))
(else
(setf (module-uses-standard-prelude? *module*) '#t)
(let ((fix-table (module-fixity-table *module*)))
(table-for-each (lambda (k v)
(setf (table-entry fix-table k) v))
*prelude-fixity-table*))))))
(let ((prelude-core (locate-module '|PreludeCore|)))
(if (eq? prelude-core '#f)
(signal-missing-prelude-core)
(when (module-prelude? *module*)
(add-imported-module prelude-core))))
(setf (module-exports *module*)
(filter-complete-module-exports (module-exports *module*))))
)
(define (add-imported-module module)
(setf (module-imports *module*)
(cons (make import-decl
(module-name (module-name module))
(module module)
(mode 'all)
(specs '())
(renamings '()))
(module-imports *module*))))
(define (filter-complete-module-exports exports)
(if (null? exports)
'()
(let ((export (car exports))
(others (filter-complete-module-exports (cdr exports))))
(if (is-type? 'entity-module export)
(let* ((name (entity-name export))
(exported-mod (locate-module name)))
(when (eq? exported-mod '#f)
(signal-undefined-module-export name))
(push exported-mod (module-exported-modules *module*))
(when (not (memq name
(cons *module-name*
(map
(lambda (import)
(import-decl-module-name import))
(module-imports *module*)))))
(signal-export-not-imported name))
others)
(cons export others)))))
(define (process-interface-imports module)
(let ((imports '()))
(dolist (i (module-imports module))
(let ((module (import-decl-module-name i))
(renamings (import-decl-renamings i)))
(dolist (s (import-decl-specs i))
(let* ((n (entity-name s))
(n1 (do-interface-rename n renamings)))
(when (assq n1 imports)
(signal-multiple-imports n1))
(push (tuple n1 (tuple module n)) imports)
(cond ((entity-class? s)
(dolist (m (entity-class-methods s))
(let ((m1 (do-interface-rename m renamings)))
(when (assq m1 imports)
(signal-multiple-imports m1))
(push (tuple m1 (tuple module m)) imports))))
((entity-datatype? s)
(dolist (m (entity-datatype-constructors s))
(let ((m1 (do-interface-rename m renamings)))
(when (assq m1 imports)
(signal-multiple-imports m1))
(push (tuple m1 (tuple module m)) imports)))))))))
(setf (module-interface-imports module) imports)))
(define (signal-multiple-imports name)
(phase-error 'multuple-interface-import
"Interface file has more than one definition of ~A~%" name))
(define (do-interface-rename name renamings)
(if (has-con-prefix? (symbol->string name))
(let* ((n1 (remove-con-prefix/symbol name))
(res (locate-renaming n1 renamings)))
(if (eq? res '#f)
name
(add-con-prefix/symbol (renaming-to res))))
(let ((res (locate-renaming name renamings)))
(if (eq? res '#f)
name
(renaming-to res)))))
|
