adamc@1
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@1
|
2 * All rights reserved.
|
adamc@1
|
3 *
|
adamc@1
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@1
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@1
|
6 *
|
adamc@1
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@1
|
8 * this list of conditions and the following disclaimer.
|
adamc@1
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@1
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@1
|
11 * and/or other materials provided with the distribution.
|
adamc@1
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@1
|
13 * derived from this software without specific prior written permission.
|
adamc@1
|
14 *
|
adamc@1
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@1
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@1
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@1
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@1
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@1
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@1
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@1
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@1
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@1
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@1
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@1
|
26 *)
|
adamc@1
|
27
|
adamc@244
|
28 (* Ur/Web language parser *)
|
adamc@1
|
29
|
adamc@1
|
30 structure Compiler :> COMPILER = struct
|
adamc@1
|
31
|
adamc@244
|
32 structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
|
adamc@244
|
33 structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
|
adamc@244
|
34 structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
|
adamc@1
|
35 structure Lex = Lex
|
adamc@1
|
36 structure LrParser = LrParser)
|
adamc@1
|
37
|
adamc@270
|
38 type job = {
|
adamc@385
|
39 prefix : string,
|
adamc@270
|
40 database : string option,
|
adamc@274
|
41 sources : string list,
|
adamc@274
|
42 exe : string,
|
adamc@274
|
43 sql : string option,
|
adamc@274
|
44 debug : bool
|
adamc@270
|
45 }
|
adamc@201
|
46
|
adamc@201
|
47 type ('src, 'dst) phase = {
|
adamc@201
|
48 func : 'src -> 'dst,
|
adamc@201
|
49 print : 'dst -> Print.PD.pp_desc
|
adamc@201
|
50 }
|
adamc@201
|
51
|
adamc@201
|
52 type pmap = (string * Time.time) list
|
adamc@201
|
53
|
adamc@201
|
54 type ('src, 'dst) transform = {
|
adamc@201
|
55 func : 'src -> 'dst option,
|
adamc@201
|
56 print : 'dst -> Print.PD.pp_desc,
|
adamc@201
|
57 time : 'src * pmap -> 'dst option * pmap
|
adamc@201
|
58 }
|
adamc@201
|
59
|
adamc@201
|
60 fun transform (ph : ('src, 'dst) phase) name = {
|
adamc@201
|
61 func = fn input => let
|
adamc@201
|
62 val v = #func ph input
|
adamc@201
|
63 in
|
adamc@201
|
64 if ErrorMsg.anyErrors () then
|
adamc@201
|
65 NONE
|
adamc@201
|
66 else
|
adamc@201
|
67 SOME v
|
adamc@201
|
68 end,
|
adamc@201
|
69 print = #print ph,
|
adamc@201
|
70 time = fn (input, pmap) => let
|
adamc@201
|
71 val befor = Time.now ()
|
adamc@201
|
72 val v = #func ph input
|
adamc@201
|
73 val elapsed = Time.- (Time.now (), befor)
|
adamc@201
|
74 in
|
adamc@201
|
75 (if ErrorMsg.anyErrors () then
|
adamc@201
|
76 NONE
|
adamc@201
|
77 else
|
adamc@201
|
78 SOME v,
|
adamc@201
|
79 (name, elapsed) :: pmap)
|
adamc@201
|
80 end
|
adamc@201
|
81 }
|
adamc@201
|
82
|
adamc@270
|
83 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
|
adamc@201
|
84 func = fn input => case #func tr1 input of
|
adamc@201
|
85 NONE => NONE
|
adamc@201
|
86 | SOME v => #func tr2 v,
|
adamc@201
|
87 print = #print tr2,
|
adamc@201
|
88 time = fn (input, pmap) => let
|
adamc@201
|
89 val (ro, pmap) = #time tr1 (input, pmap)
|
adamc@201
|
90 in
|
adamc@201
|
91 case ro of
|
adamc@201
|
92 NONE => (NONE, pmap)
|
adamc@201
|
93 | SOME v => #time tr2 (v, pmap)
|
adamc@201
|
94 end
|
adamc@201
|
95 }
|
adamc@201
|
96
|
adamc@346
|
97 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
|
adamc@346
|
98 ignore (#func tr x))
|
adamc@346
|
99
|
adamc@280
|
100 fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
|
adamc@280
|
101 #func tr x)
|
adamc@201
|
102
|
adamc@201
|
103 fun runPrint (tr : ('src, 'dst) transform) input =
|
adamc@280
|
104 (ErrorMsg.resetErrors ();
|
adamc@280
|
105 case #func tr input of
|
adamc@280
|
106 NONE => print "Failure\n"
|
adamc@280
|
107 | SOME v =>
|
adamc@280
|
108 (print "Success\n";
|
adamc@280
|
109 Print.print (#print tr v);
|
adamc@280
|
110 print "\n"))
|
adamc@201
|
111
|
adamc@201
|
112 fun time (tr : ('src, 'dst) transform) input =
|
adamc@55
|
113 let
|
adamc@201
|
114 val (_, pmap) = #time tr (input, [])
|
adamc@201
|
115 in
|
adamc@201
|
116 app (fn (name, time) =>
|
adamc@201
|
117 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
118 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
119 print "\n"
|
adamc@201
|
120 end
|
adamc@55
|
121
|
adamc@201
|
122 fun timePrint (tr : ('src, 'dst) transform) input =
|
adamc@201
|
123 let
|
adamc@201
|
124 val (ro, pmap) = #time tr (input, [])
|
adamc@55
|
125 in
|
adamc@201
|
126 app (fn (name, time) =>
|
adamc@201
|
127 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
128 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
129 print "\n";
|
adamc@201
|
130 case ro of
|
adamc@201
|
131 NONE => print "Failure\n"
|
adamc@201
|
132 | SOME v =>
|
adamc@201
|
133 (print "Success\n";
|
adamc@201
|
134 Print.print (#print tr v);
|
adamc@201
|
135 print "\n")
|
adamc@55
|
136 end
|
adamc@55
|
137
|
adamc@244
|
138 val parseUrs =
|
adamc@201
|
139 {func = fn filename => let
|
adamc@201
|
140 val fname = OS.FileSys.tmpName ()
|
adamc@201
|
141 val outf = TextIO.openOut fname
|
adamc@201
|
142 val () = TextIO.output (outf, "sig\n")
|
adamc@201
|
143 val inf = TextIO.openIn filename
|
adamc@201
|
144 fun loop () =
|
adamc@201
|
145 case TextIO.inputLine inf of
|
adamc@201
|
146 NONE => ()
|
adamc@201
|
147 | SOME line => (TextIO.output (outf, line);
|
adamc@201
|
148 loop ())
|
adamc@201
|
149 val () = loop ()
|
adamc@201
|
150 val () = TextIO.closeIn inf
|
adamc@201
|
151 val () = TextIO.closeOut outf
|
adamc@201
|
152
|
adamc@201
|
153 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
154 ErrorMsg.resetPositioning filename;
|
adamc@201
|
155 Lex.UserDeclarations.initialize ())
|
adamc@201
|
156 val file = TextIO.openIn fname
|
adamc@201
|
157 fun get _ = TextIO.input file
|
adamc@201
|
158 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
159 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
160 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
161 in
|
adamc@201
|
162 TextIO.closeIn file;
|
adamc@201
|
163 case absyn of
|
adamc@201
|
164 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
|
adamc@201
|
165 | _ => (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
166 first = {line = 0,
|
adamc@201
|
167 char = 0},
|
adamc@201
|
168 last = {line = 0,
|
adamc@201
|
169 char = 0}} "Not a signature";
|
adamc@201
|
170 [])
|
adamc@201
|
171 end
|
adamc@201
|
172 handle LrParser.ParseError => [],
|
adamc@201
|
173 print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
|
adamc@55
|
174
|
adamc@1
|
175 (* The main parsing routine *)
|
adamc@244
|
176 val parseUr = {
|
adamc@201
|
177 func = fn filename =>
|
adamc@201
|
178 let
|
adamc@201
|
179 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
180 ErrorMsg.resetPositioning filename;
|
adamc@201
|
181 Lex.UserDeclarations.initialize ())
|
adamc@201
|
182 val file = TextIO.openIn filename
|
adamc@201
|
183 fun get _ = TextIO.input file
|
adamc@201
|
184 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
185 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
186 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
187 in
|
adamc@201
|
188 TextIO.closeIn file;
|
adamc@201
|
189 case absyn of
|
adamc@201
|
190 [(Source.DSgn ("?", _), _)] =>
|
adamc@201
|
191 (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
192 first = {line = 0,
|
adamc@201
|
193 char = 0},
|
adamc@201
|
194 last = {line = 0,
|
adamc@201
|
195 char = 0}} "File starts with 'sig'";
|
adamc@201
|
196 [])
|
adamc@201
|
197 | _ => absyn
|
adamc@201
|
198 end
|
adamc@201
|
199 handle LrParser.ParseError => [],
|
adamc@201
|
200 print = SourcePrint.p_file}
|
adamc@56
|
201
|
adamc@385
|
202 fun p_job {prefix, database, exe, sql, sources, debug} =
|
adamc@270
|
203 let
|
adamc@270
|
204 open Print.PD
|
adamc@270
|
205 open Print
|
adamc@270
|
206 in
|
adamc@274
|
207 box [if debug then
|
adamc@274
|
208 box [string "DEBUG", newline]
|
adamc@274
|
209 else
|
adamc@274
|
210 box [],
|
adamc@274
|
211 case database of
|
adamc@270
|
212 NONE => string "No database."
|
adamc@270
|
213 | SOME db => string ("Database: " ^ db),
|
adamc@270
|
214 newline,
|
adamc@274
|
215 string "Exe: ",
|
adamc@274
|
216 string exe,
|
adamc@274
|
217 newline,
|
adamc@274
|
218 case sql of
|
adamc@274
|
219 NONE => string "No SQL file."
|
adamc@274
|
220 | SOME sql => string ("SQL fle: " ^ sql),
|
adamc@270
|
221 string "Sources:",
|
adamc@270
|
222 p_list string sources,
|
adamc@270
|
223 newline]
|
adamc@270
|
224 end
|
adamc@270
|
225
|
adamc@270
|
226 fun trim s =
|
adamc@270
|
227 let
|
adamc@270
|
228 val (_, s) = Substring.splitl Char.isSpace s
|
adamc@270
|
229 val (s, _) = Substring.splitr Char.isSpace s
|
adamc@270
|
230 in
|
adamc@270
|
231 s
|
adamc@270
|
232 end
|
adamc@270
|
233
|
adamc@270
|
234 val parseUrp = {
|
adamc@270
|
235 func = fn filename =>
|
adamc@270
|
236 let
|
adamc@270
|
237 val dir = OS.Path.dir filename
|
adamc@270
|
238 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
|
adamc@270
|
239
|
adamc@274
|
240 fun relify fname =
|
adamc@274
|
241 OS.Path.concat (dir, fname)
|
adamc@274
|
242 handle OS.Path.Path => fname
|
adamc@274
|
243
|
adamc@270
|
244 fun readSources acc =
|
adamc@270
|
245 case TextIO.inputLine inf of
|
adamc@270
|
246 NONE => rev acc
|
adamc@270
|
247 | SOME line =>
|
adamc@270
|
248 let
|
adamc@270
|
249 val acc = if CharVector.all Char.isSpace line then
|
adamc@270
|
250 acc
|
adamc@270
|
251 else
|
adamc@270
|
252 let
|
adamc@270
|
253 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
|
adamc@270
|
254 (String.explode line))
|
adamc@274
|
255 val fname = relify fname
|
adamc@270
|
256 in
|
adamc@270
|
257 fname :: acc
|
adamc@270
|
258 end
|
adamc@270
|
259 in
|
adamc@270
|
260 readSources acc
|
adamc@270
|
261 end
|
adamc@270
|
262
|
adamc@385
|
263 fun finish (prefix, database, exe, sql, debug, sources) =
|
adamc@385
|
264 {prefix = Option.getOpt (prefix, "/"),
|
adamc@385
|
265 database = database,
|
adamc@274
|
266 exe = Option.getOpt (exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
|
adamc@274
|
267 ext = SOME "exe"}),
|
adamc@274
|
268 sql = sql,
|
adamc@274
|
269 debug = debug,
|
adamc@274
|
270 sources = sources}
|
adamc@274
|
271
|
adamc@385
|
272 fun read (prefix, database, exe, sql, debug) =
|
adamc@270
|
273 case TextIO.inputLine inf of
|
adamc@385
|
274 NONE => finish (prefix, database, exe, sql, debug, [])
|
adamc@385
|
275 | SOME "\n" => finish (prefix, database, exe, sql, debug, readSources [])
|
adamc@270
|
276 | SOME line =>
|
adamc@270
|
277 let
|
adamc@270
|
278 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
|
adamc@270
|
279 val cmd = Substring.string (trim cmd)
|
adamc@270
|
280 val arg = Substring.string (trim arg)
|
adamc@270
|
281 in
|
adamc@270
|
282 case cmd of
|
adamc@385
|
283 "prefix" =>
|
adamc@385
|
284 (case prefix of
|
adamc@385
|
285 NONE => ()
|
adamc@385
|
286 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
|
adamc@385
|
287 read (SOME arg, database, exe, sql, debug))
|
adamc@385
|
288 | "database" =>
|
adamc@270
|
289 (case database of
|
adamc@270
|
290 NONE => ()
|
adamc@270
|
291 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
|
adamc@385
|
292 read (prefix, SOME arg, exe, sql, debug))
|
adamc@274
|
293 | "exe" =>
|
adamc@274
|
294 (case exe of
|
adamc@274
|
295 NONE => ()
|
adamc@274
|
296 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
|
adamc@385
|
297 read (prefix, database, SOME (relify arg), sql, debug))
|
adamc@274
|
298 | "sql" =>
|
adamc@274
|
299 (case sql of
|
adamc@274
|
300 NONE => ()
|
adamc@274
|
301 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
|
adamc@385
|
302 read (prefix, database, exe, SOME (relify arg), debug))
|
adamc@385
|
303 | "debug" => read (prefix, database, exe, sql, true)
|
adamc@270
|
304 | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
|
adamc@385
|
305 read (prefix, database, exe, sql, debug))
|
adamc@270
|
306 end
|
adamc@385
|
307
|
adamc@385
|
308 val job = read (NONE, NONE, NONE, NONE, false)
|
adamc@270
|
309 in
|
adamc@385
|
310 TextIO.closeIn inf;
|
adamc@385
|
311 Monoize.urlPrefix := #prefix job;
|
adamc@385
|
312 job
|
adamc@270
|
313 end,
|
adamc@270
|
314 print = p_job
|
adamc@270
|
315 }
|
adamc@270
|
316
|
adamc@270
|
317 val toParseJob = transform parseUrp "parseJob"
|
adamc@270
|
318
|
adamc@56
|
319 fun capitalize "" = ""
|
adamc@56
|
320 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@56
|
321
|
adamc@201
|
322 val parse = {
|
adamc@274
|
323 func = fn {database, sources = fnames, ...} : job =>
|
adamc@201
|
324 let
|
adamc@201
|
325 fun nameOf fname = capitalize (OS.Path.file fname)
|
adamc@109
|
326
|
adamc@201
|
327 fun parseOne fname =
|
adamc@201
|
328 let
|
adamc@201
|
329 val mname = nameOf fname
|
adamc@244
|
330 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
|
adamc@244
|
331 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@56
|
332
|
adamc@201
|
333 val sgnO =
|
adamc@244
|
334 if Posix.FileSys.access (urs, []) then
|
adamc@244
|
335 SOME (Source.SgnConst (#func parseUrs urs),
|
adamc@244
|
336 {file = urs,
|
adamc@201
|
337 first = ErrorMsg.dummyPos,
|
adamc@201
|
338 last = ErrorMsg.dummyPos})
|
adamc@201
|
339 else
|
adamc@201
|
340 NONE
|
adamc@56
|
341
|
adamc@244
|
342 val loc = {file = ur,
|
adamc@201
|
343 first = ErrorMsg.dummyPos,
|
adamc@201
|
344 last = ErrorMsg.dummyPos}
|
adamc@56
|
345
|
adamc@244
|
346 val ds = #func parseUr ur
|
adamc@201
|
347 in
|
adamc@201
|
348 (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
|
adamc@201
|
349 end
|
adamc@56
|
350
|
adamc@201
|
351 val ds = map parseOne fnames
|
adamc@201
|
352 in
|
adamc@201
|
353 let
|
adamc@201
|
354 val final = nameOf (List.last fnames)
|
adamc@271
|
355
|
adamc@271
|
356 val ds = ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
|
adamc@201
|
357 in
|
adamc@271
|
358 case database of
|
adamc@271
|
359 NONE => ds
|
adamc@271
|
360 | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds
|
adamc@201
|
361 end handle Empty => ds
|
adamc@201
|
362 end,
|
adamc@201
|
363 print = SourcePrint.p_file
|
adamc@201
|
364 }
|
adamc@56
|
365
|
adamc@270
|
366 val toParse = transform parse "parse" o toParseJob
|
adamc@38
|
367
|
adamc@378
|
368 fun libFile s = OS.Path.joinDirFile {dir = Config.libUr,
|
adamc@378
|
369 file = s}
|
adamc@378
|
370 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
|
adamc@378
|
371 file = s}
|
adamc@378
|
372
|
adamc@201
|
373 val elaborate = {
|
adamc@201
|
374 func = fn file => let
|
adamc@378
|
375 val basis = #func parseUrs (libFile "basis.urs")
|
adamc@378
|
376 val topSgn = #func parseUrs (libFile "top.urs")
|
adamc@378
|
377 val topStr = #func parseUr (libFile "top.ur")
|
adamc@201
|
378 in
|
adamc@325
|
379 Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
|
adamc@201
|
380 end,
|
adamc@201
|
381 print = ElabPrint.p_file ElabEnv.empty
|
adamc@201
|
382 }
|
adamc@5
|
383
|
adamc@270
|
384 val toElaborate = transform elaborate "elaborate" o toParse
|
adamc@201
|
385
|
adamc@313
|
386 val termination = {
|
adamc@313
|
387 func = (fn file => (Termination.check file; file)),
|
adamc@313
|
388 print = ElabPrint.p_file ElabEnv.empty
|
adamc@313
|
389 }
|
adamc@313
|
390
|
adamc@313
|
391 val toTermination = transform termination "termination" o toElaborate
|
adamc@313
|
392
|
adamc@201
|
393 val explify = {
|
adamc@201
|
394 func = Explify.explify,
|
adamc@201
|
395 print = ExplPrint.p_file ExplEnv.empty
|
adamc@201
|
396 }
|
adamc@201
|
397
|
adamc@313
|
398 val toExplify = transform explify "explify" o toTermination
|
adamc@201
|
399
|
adamc@201
|
400 val corify = {
|
adamc@201
|
401 func = Corify.corify,
|
adamc@201
|
402 print = CorePrint.p_file CoreEnv.empty
|
adamc@201
|
403 }
|
adamc@201
|
404
|
adamc@270
|
405 val toCorify = transform corify "corify" o toExplify
|
adamc@201
|
406
|
adamc@202
|
407 val shake = {
|
adamc@202
|
408 func = Shake.shake,
|
adamc@202
|
409 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
410 }
|
adamc@39
|
411
|
adamc@270
|
412 val toShake1 = transform shake "shake1" o toCorify
|
adamc@110
|
413
|
adamc@202
|
414 val tag = {
|
adamc@202
|
415 func = Tag.tag,
|
adamc@202
|
416 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
417 }
|
adamc@193
|
418
|
adamc@270
|
419 val toTag = transform tag "tag" o toShake1
|
adamc@20
|
420
|
adamc@202
|
421 val reduce = {
|
adamc@202
|
422 func = Reduce.reduce,
|
adamc@202
|
423 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
424 }
|
adamc@25
|
425
|
adamc@270
|
426 val toReduce = transform reduce "reduce" o toTag
|
adamc@23
|
427
|
adamc@315
|
428 val unpoly = {
|
adamc@315
|
429 func = Unpoly.unpoly,
|
adamc@315
|
430 print = CorePrint.p_file CoreEnv.empty
|
adamc@315
|
431 }
|
adamc@315
|
432
|
adamc@315
|
433 val toUnpoly = transform unpoly "unpoly" o toReduce
|
adamc@315
|
434
|
adamc@202
|
435 val specialize = {
|
adamc@202
|
436 func = Specialize.specialize,
|
adamc@202
|
437 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
438 }
|
adamc@132
|
439
|
adamc@315
|
440 val toSpecialize = transform specialize "specialize" o toUnpoly
|
adamc@131
|
441
|
adamc@270
|
442 val toShake2 = transform shake "shake2" o toSpecialize
|
adamc@133
|
443
|
adamc@202
|
444 val monoize = {
|
adamc@202
|
445 func = Monoize.monoize CoreEnv.empty,
|
adamc@202
|
446 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
447 }
|
adamc@134
|
448
|
adamc@270
|
449 val toMonoize = transform monoize "monoize" o toShake2
|
adamc@96
|
450
|
adamc@202
|
451 val mono_opt = {
|
adamc@202
|
452 func = MonoOpt.optimize,
|
adamc@202
|
453 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
454 }
|
adamc@29
|
455
|
adamc@270
|
456 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
|
adamc@5
|
457
|
adamc@202
|
458 val untangle = {
|
adamc@202
|
459 func = Untangle.untangle,
|
adamc@202
|
460 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
461 }
|
adamc@1
|
462
|
adamc@270
|
463 val toUntangle = transform untangle "untangle" o toMono_opt1
|
adamc@38
|
464
|
adamc@202
|
465 val mono_reduce = {
|
adamc@202
|
466 func = MonoReduce.reduce,
|
adamc@202
|
467 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
468 }
|
adamc@16
|
469
|
adamc@270
|
470 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
|
adamc@39
|
471
|
adamc@202
|
472 val mono_shake = {
|
adamc@202
|
473 func = MonoShake.shake,
|
adamc@202
|
474 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
475 }
|
adamc@110
|
476
|
adamc@270
|
477 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
|
adamc@193
|
478
|
adamc@270
|
479 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
|
adamc@20
|
480
|
adamc@377
|
481 val pathcheck = {
|
adamc@377
|
482 func = (fn file => (PathCheck.check file; file)),
|
adamc@377
|
483 print = MonoPrint.p_file MonoEnv.empty
|
adamc@377
|
484 }
|
adamc@377
|
485
|
adamc@377
|
486 val toPathcheck = transform pathcheck "pathcheck" o toMono_opt2
|
adamc@377
|
487
|
adamc@202
|
488 val cjrize = {
|
adamc@202
|
489 func = Cjrize.cjrize,
|
adamc@202
|
490 print = CjrPrint.p_file CjrEnv.empty
|
adamc@202
|
491 }
|
adamc@23
|
492
|
adamc@377
|
493 val toCjrize = transform cjrize "cjrize" o toPathcheck
|
adamc@29
|
494
|
adamc@282
|
495 val prepare = {
|
adamc@282
|
496 func = Prepare.prepare,
|
adamc@282
|
497 print = CjrPrint.p_file CjrEnv.empty
|
adamc@282
|
498 }
|
adamc@282
|
499
|
adamc@282
|
500 val toPrepare = transform prepare "prepare" o toCjrize
|
adamc@282
|
501
|
adamc@274
|
502 val sqlify = {
|
adamc@274
|
503 func = Cjrize.cjrize,
|
adamc@274
|
504 print = CjrPrint.p_sql CjrEnv.empty
|
adamc@274
|
505 }
|
adamc@274
|
506
|
adamc@274
|
507 val toSqlify = transform sqlify "sqlify" o toMono_opt2
|
adamc@274
|
508
|
adamc@432
|
509 fun compileC {cname, oname, ename, libs} =
|
adamc@183
|
510 let
|
adamc@378
|
511 val urweb_o = clibFile "urweb.o"
|
adamc@378
|
512 val driver_o = clibFile "driver.o"
|
adamc@378
|
513
|
adamc@435
|
514 val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname
|
adamc@432
|
515 val link = "gcc -Werror -O3 -lm -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename
|
adamc@183
|
516 in
|
adamc@183
|
517 if not (OS.Process.isSuccess (OS.Process.system compile)) then
|
adamc@183
|
518 print "C compilation failed\n"
|
adamc@183
|
519 else if not (OS.Process.isSuccess (OS.Process.system link)) then
|
adamc@186
|
520 print "C linking failed\n"
|
adamc@183
|
521 else
|
adamc@183
|
522 print "Success\n"
|
adamc@183
|
523 end
|
adamc@183
|
524
|
adamc@202
|
525 fun compile job =
|
adamc@282
|
526 case run toPrepare job of
|
adamc@244
|
527 NONE => print "Ur compilation failed\n"
|
adamc@29
|
528 | SOME file =>
|
adamc@202
|
529 let
|
adamc@274
|
530 val job = valOf (run (transform parseUrp "parseUrp") job)
|
adamc@102
|
531
|
adamc@274
|
532 val (cname, oname, cleanup) =
|
adamc@274
|
533 if #debug job then
|
adamc@274
|
534 ("/tmp/urweb.c", "/tmp/urweb.o", fn () => ())
|
adamc@274
|
535 else
|
adamc@274
|
536 let
|
adamc@274
|
537 val dir = OS.FileSys.tmpName ()
|
adamc@403
|
538 val () = if OS.FileSys.access (dir, []) then
|
adamc@403
|
539 OS.FileSys.remove dir
|
adamc@403
|
540 else
|
adamc@403
|
541 ()
|
adamc@274
|
542 val cname = OS.Path.joinDirFile {dir = dir, file = "urweb.c"}
|
adamc@274
|
543 val oname = OS.Path.joinDirFile {dir = dir, file = "urweb.o"}
|
adamc@274
|
544 in
|
adamc@274
|
545 OS.FileSys.mkDir dir;
|
adamc@274
|
546 (cname, oname,
|
adamc@274
|
547 fn () => (OS.FileSys.remove cname;
|
adamc@274
|
548 OS.FileSys.remove oname;
|
adamc@274
|
549 OS.FileSys.rmDir dir))
|
adamc@274
|
550 end
|
adamc@274
|
551 val ename = #exe job
|
adamc@202
|
552 in
|
adamc@274
|
553 let
|
adamc@274
|
554 val outf = TextIO.openOut cname
|
adamc@274
|
555 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@432
|
556
|
adamc@432
|
557 val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
|
adamc@432
|
558 val libs =
|
adamc@432
|
559 if hasDb then
|
adamc@432
|
560 "-lpq"
|
adamc@432
|
561 else
|
adamc@432
|
562 ""
|
adamc@274
|
563 in
|
adamc@274
|
564 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
|
adamc@415
|
565 TextIO.output1 (outf, #"\n");
|
adamc@274
|
566 TextIO.closeOut outf;
|
adamc@102
|
567
|
adamc@274
|
568 case #sql job of
|
adamc@274
|
569 NONE => ()
|
adamc@274
|
570 | SOME sql =>
|
adamc@274
|
571 let
|
adamc@274
|
572 val outf = TextIO.openOut sql
|
adamc@274
|
573 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@274
|
574 in
|
adamc@274
|
575 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
|
adamc@274
|
576 TextIO.closeOut outf
|
adamc@274
|
577 end;
|
adamc@274
|
578
|
adamc@432
|
579 compileC {cname = cname, oname = oname, ename = ename, libs = libs};
|
adamc@274
|
580
|
adamc@274
|
581 cleanup ()
|
adamc@274
|
582 end
|
adamc@274
|
583 handle ex => (((cleanup ()) handle _ => ()); raise ex)
|
adamc@202
|
584 end
|
adamc@29
|
585
|
adamc@1
|
586 end
|