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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
(*
Copyright (c) 2000
Cambridge University Technical Services Limited
Modified David C.J. Matthews 2008, 2015.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*)
(*
Title: Body of ML Compiler.
Author: Dave Matthews, Cambridge University Computer Laboratory
Copyright Cambridge University 1985
*)
functor COMPILER_BODY (
structure SYMSET :
sig
type sys
type symset
val inside: sys * symset -> bool;
val ++ : symset * symset -> symset
val abortParse: symset
val semicolon: symset
end;
structure LEX : LEXSIG
structure CODETREE : CODETREESIG
structure STRUCTVALS : STRUCTVALSIG;
structure VALUEOPS : VALUEOPSSIG;
structure EXPORTTREE: EXPORTTREESIG
structure STRUCTURES : STRUCTURESSIG
structure PARSEDEC :
sig
type lexan
type symset
type fixStatus
type program
val parseDec: symset * lexan *
{ enterFix: string * fixStatus -> unit, lookupFix: string -> fixStatus option } -> program
end;
structure DEBUG: DEBUGSIG
structure UTILITIES :
sig
val searchList: unit ->
{ apply: (string * 'a -> unit) -> unit,
enter: string * 'a -> unit,
lookup: string -> 'a option}
end;
structure PRETTY : PRETTYSIG
structure MISC :
sig
exception InternalError of string
val lookupDefault : ('a -> 'b option) -> ('a -> 'b option) -> 'a -> 'b option
val quickSort : ('a -> 'a -> bool) -> 'a list -> 'a list
end;
sharing STRUCTVALS.Sharing = VALUEOPS.Sharing = PRETTY.Sharing = STRUCTURES.Sharing
= LEX.Sharing = EXPORTTREE.Sharing = SYMSET = PARSEDEC = CODETREE
) : COMPILERBODYSIG
=
(*****************************************************************************)
(* COMPILERBODY functor body *)
(*****************************************************************************)
struct
open MISC;
open STRUCTVALS;
open PRETTY;
open LEX;
type nameSpace = VALUEOPS.nameSpace
open STRUCTURES
open EXPORTTREE
val stopSyms = let open SYMSET in op ++ (abortParse, semicolon) end
fun baseCompiler (lex : lexan, nameSpace: nameSpace, debugSwitches) :
exportTree option * (unit ->
{ fixes: (string * fixStatus) list, values: (string * values) list,
structures: (string * structVals) list, signatures: (string * signatures) list,
functors: (string * functors) list, types: (string * typeConstrSet) list }) option =
let (* let1 *)
val compilerOutput = getCompilerOutput debugSwitches
val printParsetree = DEBUG.getParameter DEBUG.parsetreeTag debugSwitches
val globals =
{
lookupFix = #lookupFix nameSpace,
lookupVal = #lookupVal nameSpace,
lookupType = #lookupType nameSpace,
lookupSig = #lookupSig nameSpace,
lookupStruct = #lookupStruct nameSpace,
lookupFunct = #lookupFunct nameSpace,
enterFix = #enterFix nameSpace,
enterVal = #enterVal nameSpace,
enterType = #enterType nameSpace,
enterStruct = #enterStruct nameSpace,
enterSig = #enterSig nameSpace,
enterFunct = #enterFunct nameSpace,
allValNames = fn () => map #1 (#allVal nameSpace ())
}
val startLocn = location lex
val () =
if SYMSET.inside (sy lex, SYMSET.semicolon)
then insymbol lex
else ()
val parentTreeNav =
case List.find (Universal.tagIs rootTreeTag) debugSwitches of
SOME opt => Universal.tagProject rootTreeTag opt
| NONE => { parent = NONE, next = NONE, previous = NONE }
in
(* An empty declaration (or end of file!) *)
if SYMSET.inside (sy lex, stopSyms)
then if errorOccurred lex (* We could have, for example, an unterminated comment. *)
then (NONE, NONE)
else (SOME(locSpan(startLocn, location lex), []),
SOME (fn () => { fixes=[], values=[], structures=[], functors=[], types=[], signatures=[] })
) (* Do nothing *)
else
let
(* create a "throw away" compiling environment for this topdec *)
val newFixEnv = UTILITIES.searchList ()
val enterFix = #enter newFixEnv
val lookupFix = lookupDefault (#lookup newFixEnv) (#lookupFix globals)
(* parse a program: a sequence of topdecs ending with a semicolon. *)
val parseTree : STRUCTURES.program =
PARSEDEC.parseDec (stopSyms, lex, {enterFix = enterFix, lookupFix = lookupFix})
val () =
if printParsetree
then compilerOutput (STRUCTURES.displayProgram (parseTree, 10000))
else ()
in
if errorOccurred lex
then (NONE, NONE) (* Error: No result and the parse tree won't be useful. *)
else
let
(* If no errors then do second pass to match identifiers
and declarations and return type of expression. *)
val () = STRUCTURES.pass2Structs (parseTree, lex, Env globals)
in
if errorOccurred lex
then (SOME(structsExportTree(parentTreeNav, parseTree)), NONE)
else
let
(* Only code-generate if there were no errors and it's not a directive. *)
val (structCode, nLocals) = STRUCTURES.gencodeStructs (parseTree, lex)
in
if errorOccurred lex
then (* Errors can be produced during the code-generation phase. *)
(SOME(structsExportTree(parentTreeNav, parseTree)), NONE) (* Error: No result. *)
else
let
val resultCode = CODETREE.genCode(structCode, debugSwitches, nLocals)
(* This is the function that is returned as the result of
the compilation. *)
fun executeCode() = STRUCTURES.pass4Structs (resultCode (), parseTree)
in
(SOME(structsExportTree (parentTreeNav, parseTree)), SOME executeCode)
end
end
end
end
end
fun compiler (nameSpace: nameSpace, getChar: unit->char option, parameters: Universal.universal list) :
exportTree option * (unit ->
{ fixes: (string * fixStatus) list, values: (string * values) list,
structures: (string * structVals) list, signatures: (string * signatures) list,
functors: (string * functors) list, types: (string * typeConstrSet) list }) option =
let
val debugSwitches = parameters
val lex = LEX.initial(getChar, debugSwitches);
val traceCompiler = DEBUG.getParameter DEBUG.traceCompilerTag debugSwitches
val compilerOutput = getCompilerOutput parameters
fun printReport s = compilerOutput(PrettyString s)
in
(
if traceCompiler
then PolyML.exception_trace (fn () => baseCompiler(lex, nameSpace, debugSwitches))
else baseCompiler(lex, nameSpace, debugSwitches)
)
handle
SML90.Interrupt =>
(
printReport "Compilation interrupted\n";
raise SML90.Interrupt
)
| InternalError s =>
let
val s' =
"Exception- InternalError: " ^ String.toString s ^ " raised while compiling"
in
printReport (s' ^ "\n");
raise Fail s'
end
| exn =>
let
val s' =
"Exception- " ^ General.exnName exn ^ " unexpectedly raised while compiling"
in
printReport (s' ^ "\n");
raise Fail s'
end
end
structure Sharing =
struct
type values = values
and typeConstrSet = typeConstrSet
and fixStatus = fixStatus
and structVals = structVals
and signatures = signatures
and functors = functors
and exportTree = exportTree
end
end; (* struct *)
|
