adamc@764
|
1 (* Copyright (c) 2008-2009, 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@1
|
28 structure Compiler :> COMPILER = struct
|
adamc@1
|
29
|
adamc@244
|
30 structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
|
adamc@244
|
31 structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens)
|
adamc@244
|
32 structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
|
adamc@1
|
33 structure Lex = Lex
|
adamc@1
|
34 structure LrParser = LrParser)
|
adamc@1
|
35
|
adamc@270
|
36 type job = {
|
adamc@385
|
37 prefix : string,
|
adamc@270
|
38 database : string option,
|
adamc@274
|
39 sources : string list,
|
adamc@274
|
40 exe : string,
|
adamc@274
|
41 sql : string option,
|
adamc@502
|
42 debug : bool,
|
adamc@673
|
43 profile : bool,
|
adamc@764
|
44 timeout : int,
|
adamc@764
|
45 ffi : string list,
|
adamc@764
|
46 link : string list,
|
adamc@765
|
47 headers : string list,
|
adamc@766
|
48 scripts : string list,
|
adamc@765
|
49 clientToServer : Settings.ffi list,
|
adamc@765
|
50 effectful : Settings.ffi list,
|
adamc@765
|
51 clientOnly : Settings.ffi list,
|
adamc@765
|
52 serverOnly : Settings.ffi list,
|
adamc@768
|
53 jsFuncs : (Settings.ffi * string) list,
|
adamc@769
|
54 rewrites : Settings.rewrite list,
|
adamc@769
|
55 filterUrl : Settings.rule list,
|
adamc@866
|
56 filterMime : Settings.rule list,
|
adamc@866
|
57 protocol : string option,
|
adamc@866
|
58 dbms : string option
|
adamc@270
|
59 }
|
adamc@201
|
60
|
adamc@201
|
61 type ('src, 'dst) phase = {
|
adamc@201
|
62 func : 'src -> 'dst,
|
adamc@201
|
63 print : 'dst -> Print.PD.pp_desc
|
adamc@201
|
64 }
|
adamc@201
|
65
|
adamc@201
|
66 type pmap = (string * Time.time) list
|
adamc@201
|
67
|
adamc@201
|
68 type ('src, 'dst) transform = {
|
adamc@201
|
69 func : 'src -> 'dst option,
|
adamc@201
|
70 print : 'dst -> Print.PD.pp_desc,
|
adamc@201
|
71 time : 'src * pmap -> 'dst option * pmap
|
adamc@201
|
72 }
|
adamc@201
|
73
|
adamc@1079
|
74 val debug = ref false
|
adamc@1079
|
75
|
adamc@201
|
76 fun transform (ph : ('src, 'dst) phase) name = {
|
adamc@201
|
77 func = fn input => let
|
adamc@1079
|
78 val () = if !debug then
|
adamc@1079
|
79 print ("Starting " ^ name ^ "....\n")
|
adamc@1079
|
80 else
|
adamc@1079
|
81 ()
|
adamc@201
|
82 val v = #func ph input
|
adamc@201
|
83 in
|
adamc@1079
|
84 if !debug then
|
adamc@1079
|
85 print ("Finished " ^ name ^ ".\n")
|
adamc@1079
|
86 else
|
adamc@1079
|
87 ();
|
adamc@201
|
88 if ErrorMsg.anyErrors () then
|
adamc@201
|
89 NONE
|
adamc@201
|
90 else
|
adamc@201
|
91 SOME v
|
adamc@201
|
92 end,
|
adamc@201
|
93 print = #print ph,
|
adamc@201
|
94 time = fn (input, pmap) => let
|
adamc@201
|
95 val befor = Time.now ()
|
adamc@201
|
96 val v = #func ph input
|
adamc@201
|
97 val elapsed = Time.- (Time.now (), befor)
|
adamc@201
|
98 in
|
adamc@201
|
99 (if ErrorMsg.anyErrors () then
|
adamc@201
|
100 NONE
|
adamc@201
|
101 else
|
adamc@201
|
102 SOME v,
|
adamc@201
|
103 (name, elapsed) :: pmap)
|
adamc@201
|
104 end
|
adamc@201
|
105 }
|
adamc@201
|
106
|
adamc@270
|
107 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
|
adamc@201
|
108 func = fn input => case #func tr1 input of
|
adamc@201
|
109 NONE => NONE
|
adamc@201
|
110 | SOME v => #func tr2 v,
|
adamc@201
|
111 print = #print tr2,
|
adamc@201
|
112 time = fn (input, pmap) => let
|
adamc@201
|
113 val (ro, pmap) = #time tr1 (input, pmap)
|
adamc@201
|
114 in
|
adamc@201
|
115 case ro of
|
adamc@201
|
116 NONE => (NONE, pmap)
|
adamc@201
|
117 | SOME v => #time tr2 (v, pmap)
|
adamc@201
|
118 end
|
adamc@201
|
119 }
|
adamc@201
|
120
|
adamc@346
|
121 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
|
adamc@346
|
122 ignore (#func tr x))
|
adamc@346
|
123
|
adamc@280
|
124 fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
|
adamc@280
|
125 #func tr x)
|
adamc@201
|
126
|
adamc@201
|
127 fun runPrint (tr : ('src, 'dst) transform) input =
|
adamc@280
|
128 (ErrorMsg.resetErrors ();
|
adamc@280
|
129 case #func tr input of
|
adamc@280
|
130 NONE => print "Failure\n"
|
adamc@280
|
131 | SOME v =>
|
adamc@280
|
132 (print "Success\n";
|
adamc@280
|
133 Print.print (#print tr v);
|
adamc@280
|
134 print "\n"))
|
adamc@201
|
135
|
adamc@201
|
136 fun time (tr : ('src, 'dst) transform) input =
|
adamc@55
|
137 let
|
adamc@201
|
138 val (_, pmap) = #time tr (input, [])
|
adamc@201
|
139 in
|
adamc@201
|
140 app (fn (name, time) =>
|
adamc@201
|
141 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
142 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
143 print "\n"
|
adamc@201
|
144 end
|
adamc@55
|
145
|
adamc@201
|
146 fun timePrint (tr : ('src, 'dst) transform) input =
|
adamc@201
|
147 let
|
adamc@201
|
148 val (ro, pmap) = #time tr (input, [])
|
adamc@55
|
149 in
|
adamc@201
|
150 app (fn (name, time) =>
|
adamc@201
|
151 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
152 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
153 print "\n";
|
adamc@201
|
154 case ro of
|
adamc@201
|
155 NONE => print "Failure\n"
|
adamc@201
|
156 | SOME v =>
|
adamc@201
|
157 (print "Success\n";
|
adamc@201
|
158 Print.print (#print tr v);
|
adamc@201
|
159 print "\n")
|
adamc@55
|
160 end
|
adamc@55
|
161
|
adamc@244
|
162 val parseUrs =
|
adamc@201
|
163 {func = fn filename => let
|
adamc@201
|
164 val fname = OS.FileSys.tmpName ()
|
adamc@201
|
165 val outf = TextIO.openOut fname
|
adamc@201
|
166 val () = TextIO.output (outf, "sig\n")
|
adamc@201
|
167 val inf = TextIO.openIn filename
|
adamc@201
|
168 fun loop () =
|
adamc@201
|
169 case TextIO.inputLine inf of
|
adamc@201
|
170 NONE => ()
|
adamc@201
|
171 | SOME line => (TextIO.output (outf, line);
|
adamc@201
|
172 loop ())
|
adamc@201
|
173 val () = loop ()
|
adamc@201
|
174 val () = TextIO.closeIn inf
|
adamc@201
|
175 val () = TextIO.closeOut outf
|
adamc@201
|
176
|
adamc@201
|
177 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
178 ErrorMsg.resetPositioning filename;
|
adamc@201
|
179 Lex.UserDeclarations.initialize ())
|
adamc@201
|
180 val file = TextIO.openIn fname
|
adamc@201
|
181 fun get _ = TextIO.input file
|
adamc@201
|
182 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
183 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
184 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
185 in
|
adamc@201
|
186 TextIO.closeIn file;
|
adamc@201
|
187 case absyn of
|
adamc@201
|
188 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
|
adamc@201
|
189 | _ => (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
190 first = {line = 0,
|
adamc@201
|
191 char = 0},
|
adamc@201
|
192 last = {line = 0,
|
adamc@201
|
193 char = 0}} "Not a signature";
|
adamc@201
|
194 [])
|
adamc@201
|
195 end
|
adamc@201
|
196 handle LrParser.ParseError => [],
|
adamc@201
|
197 print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
|
adamc@55
|
198
|
adamc@1
|
199 (* The main parsing routine *)
|
adamc@244
|
200 val parseUr = {
|
adamc@201
|
201 func = fn filename =>
|
adamc@201
|
202 let
|
adamc@201
|
203 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
204 ErrorMsg.resetPositioning filename;
|
adamc@201
|
205 Lex.UserDeclarations.initialize ())
|
adamc@201
|
206 val file = TextIO.openIn filename
|
adamc@201
|
207 fun get _ = TextIO.input file
|
adamc@201
|
208 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
209 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
210 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
211 in
|
adamc@201
|
212 TextIO.closeIn file;
|
adamc@201
|
213 case absyn of
|
adamc@201
|
214 [(Source.DSgn ("?", _), _)] =>
|
adamc@201
|
215 (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
216 first = {line = 0,
|
adamc@201
|
217 char = 0},
|
adamc@201
|
218 last = {line = 0,
|
adamc@201
|
219 char = 0}} "File starts with 'sig'";
|
adamc@201
|
220 [])
|
adamc@201
|
221 | _ => absyn
|
adamc@201
|
222 end
|
adamc@201
|
223 handle LrParser.ParseError => [],
|
adamc@201
|
224 print = SourcePrint.p_file}
|
adamc@56
|
225
|
adamc@768
|
226 fun p_job ({prefix, database, exe, sql, sources, debug, profile,
|
adamc@768
|
227 timeout, ffi, link, headers, scripts,
|
adamc@768
|
228 clientToServer, effectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
|
adamc@270
|
229 let
|
adamc@270
|
230 open Print.PD
|
adamc@270
|
231 open Print
|
adamc@765
|
232
|
adamc@765
|
233 fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
|
adamc@765
|
234 box [string name, space, string m, string ".", string s, newline])
|
adamc@270
|
235 in
|
adamc@274
|
236 box [if debug then
|
adamc@274
|
237 box [string "DEBUG", newline]
|
adamc@274
|
238 else
|
adamc@274
|
239 box [],
|
adamc@502
|
240 if profile then
|
adamc@502
|
241 box [string "PROFILE", newline]
|
adamc@502
|
242 else
|
adamc@502
|
243 box [],
|
adamc@274
|
244 case database of
|
adamc@270
|
245 NONE => string "No database."
|
adamc@270
|
246 | SOME db => string ("Database: " ^ db),
|
adamc@270
|
247 newline,
|
adamc@274
|
248 string "Exe: ",
|
adamc@274
|
249 string exe,
|
adamc@274
|
250 newline,
|
adamc@274
|
251 case sql of
|
adamc@274
|
252 NONE => string "No SQL file."
|
adamc@274
|
253 | SOME sql => string ("SQL fle: " ^ sql),
|
adamc@673
|
254 newline,
|
adamc@673
|
255 string "Timeout: ",
|
adamc@673
|
256 string (Int.toString timeout),
|
adamc@673
|
257 newline,
|
adamc@764
|
258 p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
|
adamc@764
|
259 p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
|
adamc@766
|
260 p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts,
|
adamc@764
|
261 p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
|
adamc@765
|
262 p_ffi "ClientToServer" clientToServer,
|
adamc@765
|
263 p_ffi "Effectful" effectful,
|
adamc@765
|
264 p_ffi "ClientOnly" clientOnly,
|
adamc@765
|
265 p_ffi "ServerOnly" serverOnly,
|
adamc@765
|
266 p_list_sep (box []) (fn ((m, s), s') =>
|
adamc@765
|
267 box [string "JsFunc", space, string m, string ".", string s,
|
adamc@765
|
268 space, string "=", space, string s', newline]) jsFuncs,
|
adamc@270
|
269 string "Sources:",
|
adamc@270
|
270 p_list string sources,
|
adamc@270
|
271 newline]
|
adamc@270
|
272 end
|
adamc@270
|
273
|
adamc@270
|
274 fun trim s =
|
adamc@270
|
275 let
|
adamc@270
|
276 val (_, s) = Substring.splitl Char.isSpace s
|
adamc@270
|
277 val (s, _) = Substring.splitr Char.isSpace s
|
adamc@270
|
278 in
|
adamc@270
|
279 s
|
adamc@270
|
280 end
|
adamc@270
|
281
|
adamc@794
|
282 structure M = BinaryMapFn(struct
|
adamc@794
|
283 type ord_key = string
|
adamc@794
|
284 val compare = String.compare
|
adamc@794
|
285 end)
|
adamc@794
|
286
|
adamc@794
|
287 fun parseUrp' fname =
|
adamc@767
|
288 let
|
adamc@794
|
289 val pathmap = ref (M.insert (M.empty, "", Config.libUr))
|
adamc@767
|
290
|
adamc@794
|
291 fun pu filename =
|
adamc@794
|
292 let
|
adamc@794
|
293 val dir = OS.Path.dir filename
|
adamc@794
|
294 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
|
adamc@767
|
295
|
adamc@794
|
296 fun pathify fname =
|
adamc@794
|
297 if size fname > 0 andalso String.sub (fname, 0) = #"$" then
|
adamc@794
|
298 let
|
adamc@794
|
299 val fname' = Substring.extract (fname, 1, NONE)
|
adamc@794
|
300 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
|
adamc@794
|
301 in
|
adamc@794
|
302 if Substring.isEmpty after then
|
adamc@794
|
303 fname
|
adamc@794
|
304 else
|
adamc@794
|
305 case M.find (!pathmap, Substring.string befor) of
|
adamc@794
|
306 NONE => fname
|
adamc@794
|
307 | SOME rep => rep ^ Substring.string after
|
adamc@794
|
308 end
|
adamc@794
|
309 else
|
adamc@794
|
310 fname
|
adamc@767
|
311
|
adamc@794
|
312 fun relify fname =
|
adamc@794
|
313 let
|
adamc@794
|
314 val fname = pathify fname
|
adamc@794
|
315 in
|
adamc@794
|
316 OS.Path.concat (dir, fname)
|
adamc@794
|
317 handle OS.Path.Path => fname
|
adamc@794
|
318 end
|
adamc@767
|
319
|
adamc@794
|
320 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
|
adamc@767
|
321
|
adamc@794
|
322 fun relifyA fname =
|
adamc@794
|
323 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
|
adamc@767
|
324
|
adamc@794
|
325 fun readSources acc =
|
adamc@794
|
326 case TextIO.inputLine inf of
|
adamc@794
|
327 NONE => rev acc
|
adamc@794
|
328 | SOME line =>
|
adamc@794
|
329 let
|
adamc@794
|
330 val acc = if CharVector.all Char.isSpace line then
|
adamc@794
|
331 acc
|
adamc@794
|
332 else
|
adamc@794
|
333 let
|
adamc@794
|
334 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
|
adamc@794
|
335 (String.explode line))
|
adamc@794
|
336 val fname = relify fname
|
adamc@794
|
337 in
|
adamc@794
|
338 fname :: acc
|
adamc@794
|
339 end
|
adamc@794
|
340 in
|
adamc@794
|
341 readSources acc
|
adamc@794
|
342 end
|
adamc@767
|
343
|
adamc@794
|
344 val prefix = ref NONE
|
adamc@891
|
345 val database = ref (Settings.getDbstring ())
|
adamc@891
|
346 val exe = ref (Settings.getExe ())
|
adamc@891
|
347 val sql = ref (Settings.getSql ())
|
adamc@857
|
348 val debug = ref (Settings.getDebug ())
|
adamc@794
|
349 val profile = ref false
|
adamc@794
|
350 val timeout = ref NONE
|
adamc@794
|
351 val ffi = ref []
|
adamc@794
|
352 val link = ref []
|
adamc@794
|
353 val headers = ref []
|
adamc@794
|
354 val scripts = ref []
|
adamc@794
|
355 val clientToServer = ref []
|
adamc@794
|
356 val effectful = ref []
|
adamc@794
|
357 val clientOnly = ref []
|
adamc@794
|
358 val serverOnly = ref []
|
adamc@794
|
359 val jsFuncs = ref []
|
adamc@794
|
360 val rewrites = ref []
|
adamc@794
|
361 val url = ref []
|
adamc@794
|
362 val mime = ref []
|
adamc@794
|
363 val libs = ref []
|
adamc@866
|
364 val protocol = ref NONE
|
adamc@866
|
365 val dbms = ref NONE
|
adamc@767
|
366
|
adamc@794
|
367 fun finish sources =
|
adamc@794
|
368 let
|
adamc@794
|
369 val job = {
|
adamc@794
|
370 prefix = Option.getOpt (!prefix, "/"),
|
adamc@794
|
371 database = !database,
|
adamc@794
|
372 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
|
adamc@794
|
373 ext = SOME "exe"}),
|
adamc@794
|
374 sql = !sql,
|
adamc@794
|
375 debug = !debug,
|
adamc@794
|
376 profile = !profile,
|
adamc@794
|
377 timeout = Option.getOpt (!timeout, 60),
|
adamc@794
|
378 ffi = rev (!ffi),
|
adamc@794
|
379 link = rev (!link),
|
adamc@794
|
380 headers = rev (!headers),
|
adamc@794
|
381 scripts = rev (!scripts),
|
adamc@794
|
382 clientToServer = rev (!clientToServer),
|
adamc@794
|
383 effectful = rev (!effectful),
|
adamc@794
|
384 clientOnly = rev (!clientOnly),
|
adamc@794
|
385 serverOnly = rev (!serverOnly),
|
adamc@794
|
386 jsFuncs = rev (!jsFuncs),
|
adamc@794
|
387 rewrites = rev (!rewrites),
|
adamc@794
|
388 filterUrl = rev (!url),
|
adamc@794
|
389 filterMime = rev (!mime),
|
adamc@866
|
390 sources = sources,
|
adamc@866
|
391 protocol = !protocol,
|
adamc@866
|
392 dbms = !dbms
|
adamc@794
|
393 }
|
adamc@767
|
394
|
adamc@794
|
395 fun mergeO f (old, new) =
|
adamc@794
|
396 case (old, new) of
|
adamc@794
|
397 (NONE, _) => new
|
adamc@794
|
398 | (_, NONE) => old
|
adamc@794
|
399 | (SOME v1, SOME v2) => SOME (f (v1, v2))
|
adamc@794
|
400
|
adamc@794
|
401 fun same desc = mergeO (fn (x : string, y) =>
|
adamc@794
|
402 (if x = y then
|
adamc@794
|
403 ()
|
adamc@794
|
404 else
|
adamc@794
|
405 ErrorMsg.error ("Multiple "
|
adamc@794
|
406 ^ desc ^ " values that don't agree");
|
adamc@794
|
407 x))
|
adamc@794
|
408
|
adamc@794
|
409 fun merge (old : job, new : job) = {
|
adamc@794
|
410 prefix = #prefix old,
|
adamc@891
|
411 database = mergeO (fn (old, _) => old) (#database old, #database new),
|
adamc@794
|
412 exe = #exe old,
|
adamc@794
|
413 sql = #sql old,
|
adamc@794
|
414 debug = #debug old orelse #debug new,
|
adamc@794
|
415 profile = #profile old orelse #profile new,
|
adamc@794
|
416 timeout = #timeout old,
|
adamc@794
|
417 ffi = #ffi old @ #ffi new,
|
adamc@794
|
418 link = #link old @ #link new,
|
adamc@794
|
419 headers = #headers old @ #headers new,
|
adamc@794
|
420 scripts = #scripts old @ #scripts new,
|
adamc@794
|
421 clientToServer = #clientToServer old @ #clientToServer new,
|
adamc@794
|
422 effectful = #effectful old @ #effectful new,
|
adamc@794
|
423 clientOnly = #clientOnly old @ #clientOnly new,
|
adamc@794
|
424 serverOnly = #serverOnly old @ #serverOnly new,
|
adamc@794
|
425 jsFuncs = #jsFuncs old @ #jsFuncs new,
|
adamc@794
|
426 rewrites = #rewrites old @ #rewrites new,
|
adamc@794
|
427 filterUrl = #filterUrl old @ #filterUrl new,
|
adamc@794
|
428 filterMime = #filterMime old @ #filterMime new,
|
adamc@866
|
429 sources = #sources new @ #sources old,
|
adamc@866
|
430 protocol = mergeO #2 (#protocol old, #protocol new),
|
adamc@866
|
431 dbms = mergeO #2 (#dbms old, #dbms new)
|
adamc@794
|
432 }
|
adamc@794
|
433 in
|
adamc@1057
|
434 foldr (fn (job', job) => merge (job, job')) job (!libs)
|
adamc@794
|
435 end
|
adamc@794
|
436
|
adamc@794
|
437 fun parsePkind s =
|
adamc@794
|
438 case s of
|
adamc@794
|
439 "all" => Settings.Any
|
adamc@794
|
440 | "url" => Settings.Url
|
adamc@794
|
441 | "table" => Settings.Table
|
adamc@794
|
442 | "sequence" => Settings.Sequence
|
adamc@794
|
443 | "view" => Settings.View
|
adamc@794
|
444 | "relation" => Settings.Relation
|
adamc@794
|
445 | "cookie" => Settings.Cookie
|
adamc@794
|
446 | "style" => Settings.Style
|
adamc@794
|
447 | _ => (ErrorMsg.error "Bad path kind spec";
|
adamc@794
|
448 Settings.Any)
|
adamc@794
|
449
|
adamc@794
|
450 fun parseFrom s =
|
adamc@794
|
451 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
|
adamc@794
|
452 (Settings.Prefix, String.substring (s, 0, size s - 1))
|
adamc@794
|
453 else
|
adamc@794
|
454 (Settings.Exact, s)
|
adamc@794
|
455
|
adamc@794
|
456 fun parseFkind s =
|
adamc@794
|
457 case s of
|
adamc@794
|
458 "url" => url
|
adamc@794
|
459 | "mime" => mime
|
adamc@794
|
460 | _ => (ErrorMsg.error "Bad filter kind";
|
adamc@794
|
461 url)
|
adamc@794
|
462
|
adamc@794
|
463 fun parsePattern s =
|
adamc@794
|
464 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
|
adamc@794
|
465 (Settings.Prefix, String.substring (s, 0, size s - 1))
|
adamc@794
|
466 else
|
adamc@794
|
467 (Settings.Exact, s)
|
adamc@794
|
468
|
adamc@794
|
469 fun read () =
|
adamc@794
|
470 case TextIO.inputLine inf of
|
adamc@794
|
471 NONE => finish []
|
adamc@794
|
472 | SOME "\n" => finish (readSources [])
|
adamc@794
|
473 | SOME line =>
|
adamc@794
|
474 let
|
adamc@794
|
475 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
|
adamc@794
|
476 val cmd = Substring.string (trim cmd)
|
adamc@794
|
477 val arg = Substring.string (trim arg)
|
adamc@794
|
478
|
adamc@794
|
479 fun ffiS () =
|
adamc@794
|
480 case String.fields (fn ch => ch = #".") arg of
|
adamc@794
|
481 [m, x] => (m, x)
|
adamc@794
|
482 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
|
adamc@794
|
483 ("", ""))
|
adamc@794
|
484
|
adamc@794
|
485 fun ffiM () =
|
adamc@794
|
486 case String.fields (fn ch => ch = #"=") arg of
|
adamc@794
|
487 [f, s] =>
|
adamc@794
|
488 (case String.fields (fn ch => ch = #".") f of
|
adamc@794
|
489 [m, x] => ((m, x), s)
|
adamc@794
|
490 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
|
adamc@794
|
491 (("", ""), "")))
|
adamc@794
|
492 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
|
adamc@794
|
493 (("", ""), ""))
|
adamc@794
|
494 in
|
adamc@794
|
495 case cmd of
|
adamc@794
|
496 "prefix" =>
|
adamc@794
|
497 (case !prefix of
|
adamc@794
|
498 NONE => ()
|
adamc@794
|
499 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
|
adamc@794
|
500 prefix := SOME arg)
|
adamc@794
|
501 | "database" =>
|
adamc@794
|
502 (case !database of
|
adamc@891
|
503 NONE => database := SOME arg
|
adamc@891
|
504 | SOME _ => ())
|
adamc@794
|
505 | "exe" =>
|
adamc@794
|
506 (case !exe of
|
adamc@891
|
507 NONE => exe := SOME (relify arg)
|
adamc@891
|
508 | SOME _ => ())
|
adamc@794
|
509 | "sql" =>
|
adamc@794
|
510 (case !sql of
|
adamc@891
|
511 NONE => sql := SOME (relify arg)
|
adamc@891
|
512 | SOME _ => ())
|
adamc@794
|
513 | "debug" => debug := true
|
adamc@794
|
514 | "profile" => profile := true
|
adamc@794
|
515 | "timeout" =>
|
adamc@794
|
516 (case !timeout of
|
adamc@794
|
517 NONE => ()
|
adamc@794
|
518 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
|
adamc@794
|
519 timeout := SOME (valOf (Int.fromString arg)))
|
adamc@794
|
520 | "ffi" => ffi := relify arg :: !ffi
|
adamc@1061
|
521 | "link" => let
|
adamc@1061
|
522 val arg = if size arg >= 2 andalso String.substring (arg, 0, 2) = "-l" then
|
adamc@1061
|
523 arg
|
adamc@1061
|
524 else
|
adamc@1061
|
525 relifyA arg
|
adamc@1061
|
526 in
|
adamc@1061
|
527 link := arg :: !link
|
adamc@1061
|
528 end
|
adamc@794
|
529 | "include" => headers := relifyA arg :: !headers
|
adamc@794
|
530 | "script" => scripts := arg :: !scripts
|
adamc@794
|
531 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
|
adamc@794
|
532 | "effectful" => effectful := ffiS () :: !effectful
|
adamc@794
|
533 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
|
adamc@794
|
534 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
|
adamc@794
|
535 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
|
adamc@794
|
536 | "rewrite" =>
|
adamc@794
|
537 let
|
adamc@794
|
538 fun doit (pkind, from, to) =
|
adamc@794
|
539 let
|
adamc@794
|
540 val pkind = parsePkind pkind
|
adamc@794
|
541 val (kind, from) = parseFrom from
|
adamc@794
|
542 in
|
adamc@794
|
543 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
|
adamc@794
|
544 end
|
adamc@794
|
545 in
|
adamc@794
|
546 case String.tokens Char.isSpace arg of
|
adamc@794
|
547 [pkind, from, to] => doit (pkind, from, to)
|
adamc@794
|
548 | [pkind, from] => doit (pkind, from, "")
|
adamc@794
|
549 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
|
adamc@794
|
550 end
|
adamc@794
|
551 | "allow" =>
|
adamc@794
|
552 (case String.tokens Char.isSpace arg of
|
adamc@794
|
553 [fkind, pattern] =>
|
adamc@794
|
554 let
|
adamc@794
|
555 val fkind = parseFkind fkind
|
adamc@794
|
556 val (kind, pattern) = parsePattern pattern
|
adamc@794
|
557 in
|
adamc@794
|
558 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
|
adamc@794
|
559 end
|
adamc@794
|
560 | _ => ErrorMsg.error "Bad 'allow' syntax")
|
adamc@794
|
561 | "deny" =>
|
adamc@794
|
562 (case String.tokens Char.isSpace arg of
|
adamc@794
|
563 [fkind, pattern] =>
|
adamc@794
|
564 let
|
adamc@794
|
565 val fkind = parseFkind fkind
|
adamc@794
|
566 val (kind, pattern) = parsePattern pattern
|
adamc@794
|
567 in
|
adamc@794
|
568 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
|
adamc@794
|
569 end
|
adamc@794
|
570 | _ => ErrorMsg.error "Bad 'deny' syntax")
|
adamc@1057
|
571 | "library" => libs := pu (relify arg) :: !libs
|
adamc@794
|
572 | "path" =>
|
adamc@794
|
573 (case String.fields (fn ch => ch = #"=") arg of
|
adamc@794
|
574 [n, v] => pathmap := M.insert (!pathmap, n, v)
|
adamc@794
|
575 | _ => ErrorMsg.error "path argument not of the form name=value'")
|
adamc@794
|
576 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
|
adamc@794
|
577 read ()
|
adamc@794
|
578 end
|
adamc@794
|
579
|
adamc@794
|
580 val job = read ()
|
adamc@767
|
581 in
|
adamc@794
|
582 TextIO.closeIn inf;
|
adamc@794
|
583 Settings.setUrlPrefix (#prefix job);
|
adamc@794
|
584 Settings.setTimeout (#timeout job);
|
adamc@794
|
585 Settings.setHeaders (#headers job);
|
adamc@794
|
586 Settings.setScripts (#scripts job);
|
adamc@794
|
587 Settings.setClientToServer (#clientToServer job);
|
adamc@794
|
588 Settings.setEffectful (#effectful job);
|
adamc@794
|
589 Settings.setClientOnly (#clientOnly job);
|
adamc@794
|
590 Settings.setServerOnly (#serverOnly job);
|
adamc@794
|
591 Settings.setJsFuncs (#jsFuncs job);
|
adamc@794
|
592 Settings.setRewriteRules (#rewrites job);
|
adamc@794
|
593 Settings.setUrlRules (#filterUrl job);
|
adamc@794
|
594 Settings.setMimeRules (#filterMime job);
|
adamc@866
|
595 Option.app Settings.setProtocol (#protocol job);
|
adamc@866
|
596 Option.app Settings.setDbms (#dbms job);
|
adamc@794
|
597 job
|
adamc@767
|
598 end
|
adamc@767
|
599 in
|
adamc@794
|
600 pu fname
|
adamc@767
|
601 end
|
adamc@767
|
602
|
adamc@270
|
603 val parseUrp = {
|
adamc@767
|
604 func = parseUrp',
|
adamc@270
|
605 print = p_job
|
adamc@270
|
606 }
|
adamc@270
|
607
|
adamc@270
|
608 val toParseJob = transform parseUrp "parseJob"
|
adamc@270
|
609
|
adamc@56
|
610 fun capitalize "" = ""
|
adamc@56
|
611 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@56
|
612
|
adamc@201
|
613 val parse = {
|
adamc@764
|
614 func = fn {database, sources = fnames, ffi, ...} : job =>
|
adamc@201
|
615 let
|
adamc@834
|
616 val anyErrors = ref false
|
adamc@834
|
617 fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ())
|
adamc@201
|
618 fun nameOf fname = capitalize (OS.Path.file fname)
|
adamc@109
|
619
|
adamc@764
|
620 fun parseFfi fname =
|
adamc@764
|
621 let
|
adamc@764
|
622 val mname = nameOf fname
|
adamc@764
|
623 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@764
|
624
|
adamc@764
|
625 val loc = {file = urs,
|
adamc@764
|
626 first = ErrorMsg.dummyPos,
|
adamc@764
|
627 last = ErrorMsg.dummyPos}
|
adamc@764
|
628
|
adamc@764
|
629 val sgn = (Source.SgnConst (#func parseUrs urs), loc)
|
adamc@764
|
630 in
|
adamc@834
|
631 checkErrors ();
|
adamc@764
|
632 (Source.DFfiStr (mname, sgn), loc)
|
adamc@764
|
633 end
|
adamc@764
|
634
|
adamc@201
|
635 fun parseOne fname =
|
adamc@201
|
636 let
|
adamc@201
|
637 val mname = nameOf fname
|
adamc@244
|
638 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
|
adamc@244
|
639 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@56
|
640
|
adamc@201
|
641 val sgnO =
|
adamc@244
|
642 if Posix.FileSys.access (urs, []) then
|
adamc@244
|
643 SOME (Source.SgnConst (#func parseUrs urs),
|
adamc@244
|
644 {file = urs,
|
adamc@201
|
645 first = ErrorMsg.dummyPos,
|
adamc@201
|
646 last = ErrorMsg.dummyPos})
|
adamc@834
|
647 before checkErrors ()
|
adamc@201
|
648 else
|
adamc@201
|
649 NONE
|
adamc@56
|
650
|
adamc@244
|
651 val loc = {file = ur,
|
adamc@201
|
652 first = ErrorMsg.dummyPos,
|
adamc@201
|
653 last = ErrorMsg.dummyPos}
|
adamc@56
|
654
|
adamc@244
|
655 val ds = #func parseUr ur
|
adamc@201
|
656 in
|
adamc@834
|
657 checkErrors ();
|
adamc@201
|
658 (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
|
adamc@201
|
659 end
|
adamc@56
|
660
|
adamc@764
|
661 val dsFfi = map parseFfi ffi
|
adamc@201
|
662 val ds = map parseOne fnames
|
adamc@201
|
663 in
|
adamc@834
|
664 if !anyErrors then
|
adamc@834
|
665 ErrorMsg.error "Parse failure"
|
adamc@834
|
666 else
|
adamc@834
|
667 ();
|
adamc@834
|
668
|
adamc@201
|
669 let
|
adamc@201
|
670 val final = nameOf (List.last fnames)
|
adamc@271
|
671
|
adamc@764
|
672 val ds = dsFfi @ ds
|
adamc@764
|
673 @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
|
adamc@201
|
674 in
|
adamc@271
|
675 case database of
|
adamc@271
|
676 NONE => ds
|
adamc@271
|
677 | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds
|
adamc@201
|
678 end handle Empty => ds
|
adamc@201
|
679 end,
|
adamc@201
|
680 print = SourcePrint.p_file
|
adamc@201
|
681 }
|
adamc@56
|
682
|
adamc@270
|
683 val toParse = transform parse "parse" o toParseJob
|
adamc@38
|
684
|
adamc@378
|
685 fun libFile s = OS.Path.joinDirFile {dir = Config.libUr,
|
adamc@378
|
686 file = s}
|
adamc@378
|
687 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
|
adamc@378
|
688 file = s}
|
adamc@378
|
689
|
adamc@201
|
690 val elaborate = {
|
adamc@201
|
691 func = fn file => let
|
adamc@378
|
692 val basis = #func parseUrs (libFile "basis.urs")
|
adamc@378
|
693 val topSgn = #func parseUrs (libFile "top.urs")
|
adamc@378
|
694 val topStr = #func parseUr (libFile "top.ur")
|
adamc@201
|
695 in
|
adamc@325
|
696 Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
|
adamc@201
|
697 end,
|
adamc@201
|
698 print = ElabPrint.p_file ElabEnv.empty
|
adamc@201
|
699 }
|
adamc@5
|
700
|
adamc@270
|
701 val toElaborate = transform elaborate "elaborate" o toParse
|
adamc@201
|
702
|
adamc@448
|
703 val unnest = {
|
adamc@448
|
704 func = Unnest.unnest,
|
adamc@448
|
705 print = ElabPrint.p_file ElabEnv.empty
|
adamc@448
|
706 }
|
adamc@448
|
707
|
adamc@448
|
708 val toUnnest = transform unnest "unnest" o toElaborate
|
adamc@448
|
709
|
adamc@313
|
710 val termination = {
|
adamc@313
|
711 func = (fn file => (Termination.check file; file)),
|
adamc@313
|
712 print = ElabPrint.p_file ElabEnv.empty
|
adamc@313
|
713 }
|
adamc@313
|
714
|
adamc@448
|
715 val toTermination = transform termination "termination" o toUnnest
|
adamc@313
|
716
|
adamc@201
|
717 val explify = {
|
adamc@201
|
718 func = Explify.explify,
|
adamc@201
|
719 print = ExplPrint.p_file ExplEnv.empty
|
adamc@201
|
720 }
|
adamc@201
|
721
|
adamc@625
|
722 val toExplify = transform explify "explify" o toUnnest
|
adamc@201
|
723
|
adamc@201
|
724 val corify = {
|
adamc@201
|
725 func = Corify.corify,
|
adamc@201
|
726 print = CorePrint.p_file CoreEnv.empty
|
adamc@201
|
727 }
|
adamc@201
|
728
|
adamc@270
|
729 val toCorify = transform corify "corify" o toExplify
|
adamc@201
|
730
|
adamc@482
|
731 (*val reduce_local = {
|
adamc@482
|
732 func = ReduceLocal.reduce,
|
adamc@482
|
733 print = CorePrint.p_file CoreEnv.empty
|
adamc@482
|
734 }
|
adamc@482
|
735
|
adamc@482
|
736 val toReduce_local = transform reduce_local "reduce_local" o toCorify*)
|
adamc@482
|
737
|
adamc@443
|
738 val especialize = {
|
adamc@443
|
739 func = ESpecialize.specialize,
|
adamc@443
|
740 print = CorePrint.p_file CoreEnv.empty
|
adamc@443
|
741 }
|
adamc@443
|
742
|
adamc@454
|
743 val core_untangle = {
|
adamc@454
|
744 func = CoreUntangle.untangle,
|
adamc@454
|
745 print = CorePrint.p_file CoreEnv.empty
|
adamc@454
|
746 }
|
adamc@454
|
747
|
adamc@794
|
748 val toCore_untangle = transform core_untangle "core_untangle" o toCorify
|
adamc@454
|
749
|
adamc@202
|
750 val shake = {
|
adamc@202
|
751 func = Shake.shake,
|
adamc@202
|
752 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
753 }
|
adamc@39
|
754
|
adamc@454
|
755 val toShake1 = transform shake "shake1" o toCore_untangle
|
adamc@110
|
756
|
adamc@607
|
757 val rpcify = {
|
adamc@607
|
758 func = Rpcify.frob,
|
adamc@607
|
759 print = CorePrint.p_file CoreEnv.empty
|
adamc@607
|
760 }
|
adamc@607
|
761
|
adamc@607
|
762 val toRpcify = transform rpcify "rpcify" o toShake1
|
adamc@607
|
763
|
adamc@642
|
764 val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
|
adamc@642
|
765 val toShake2 = transform shake "shake2" o toCore_untangle2
|
adamc@1062
|
766 val toEspecialize1 = transform especialize "especialize1" o toShake2
|
adamc@1062
|
767 val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1
|
adamc@1062
|
768 val toShake3 = transform shake "shake3" o toCore_untangle3
|
adamc@642
|
769
|
adamc@202
|
770 val tag = {
|
adamc@202
|
771 func = Tag.tag,
|
adamc@202
|
772 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
773 }
|
adamc@193
|
774
|
adamc@1062
|
775 val toTag = transform tag "tag" o toShake3
|
adamc@20
|
776
|
adamc@202
|
777 val reduce = {
|
adamc@202
|
778 func = Reduce.reduce,
|
adamc@202
|
779 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
780 }
|
adamc@25
|
781
|
adamc@692
|
782 val toReduce = transform reduce "reduce" o toTag
|
adamc@23
|
783
|
adamc@315
|
784 val unpoly = {
|
adamc@315
|
785 func = Unpoly.unpoly,
|
adamc@315
|
786 print = CorePrint.p_file CoreEnv.empty
|
adamc@315
|
787 }
|
adamc@315
|
788
|
adamc@315
|
789 val toUnpoly = transform unpoly "unpoly" o toReduce
|
adamc@315
|
790
|
adamc@202
|
791 val specialize = {
|
adamc@202
|
792 func = Specialize.specialize,
|
adamc@202
|
793 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
794 }
|
adamc@132
|
795
|
adamc@315
|
796 val toSpecialize = transform specialize "specialize" o toUnpoly
|
adamc@131
|
797
|
adamc@1062
|
798 val toShake4 = transform shake "shake4" o toSpecialize
|
adamc@133
|
799
|
adamc@1062
|
800 val toEspecialize2 = transform especialize "especialize2" o toShake4
|
adamc@794
|
801
|
adamc@1062
|
802 val toReduce2 = transform reduce "reduce2" o toEspecialize2
|
adamc@898
|
803
|
adamc@1062
|
804 val toShake5 = transform shake "shake5" o toReduce2
|
adamc@794
|
805
|
adamc@692
|
806 val marshalcheck = {
|
adamc@692
|
807 func = (fn file => (MarshalCheck.check file; file)),
|
adamc@692
|
808 print = CorePrint.p_file CoreEnv.empty
|
adamc@692
|
809 }
|
adamc@692
|
810
|
adamc@1062
|
811 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5
|
adamc@692
|
812
|
adamc@732
|
813 val effectize = {
|
adamc@732
|
814 func = Effective.effectize,
|
adamc@732
|
815 print = CorePrint.p_file CoreEnv.empty
|
adamc@732
|
816 }
|
adamc@732
|
817
|
adamc@732
|
818 val toEffectize = transform effectize "effectize" o toMarshalcheck
|
adamc@732
|
819
|
adamc@202
|
820 val monoize = {
|
adamc@202
|
821 func = Monoize.monoize CoreEnv.empty,
|
adamc@202
|
822 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
823 }
|
adamc@134
|
824
|
adamc@732
|
825 val toMonoize = transform monoize "monoize" o toEffectize
|
adamc@96
|
826
|
adamc@202
|
827 val mono_opt = {
|
adamc@910
|
828 func = MonoOpt.optimize,
|
adamc@202
|
829 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
830 }
|
adamc@29
|
831
|
adamc@270
|
832 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
|
adamc@5
|
833
|
adamc@202
|
834 val untangle = {
|
adamc@202
|
835 func = Untangle.untangle,
|
adamc@202
|
836 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
837 }
|
adamc@1
|
838
|
adamc@270
|
839 val toUntangle = transform untangle "untangle" o toMono_opt1
|
adamc@38
|
840
|
adamc@202
|
841 val mono_reduce = {
|
adamc@202
|
842 func = MonoReduce.reduce,
|
adamc@202
|
843 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
844 }
|
adamc@16
|
845
|
adamc@270
|
846 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
|
adamc@39
|
847
|
adamc@202
|
848 val mono_shake = {
|
adamc@202
|
849 func = MonoShake.shake,
|
adamc@202
|
850 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
851 }
|
adamc@110
|
852
|
adamc@270
|
853 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
|
adamc@193
|
854
|
adamc@572
|
855 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
|
adamc@572
|
856
|
adamc@567
|
857 val jscomp = {
|
adamc@567
|
858 func = JsComp.process,
|
adamc@567
|
859 print = MonoPrint.p_file MonoEnv.empty
|
adamc@567
|
860 }
|
adamc@567
|
861
|
adamc@572
|
862 val toJscomp = transform jscomp "jscomp" o toMono_opt2
|
adamc@567
|
863
|
adamc@910
|
864 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
|
adamc@20
|
865
|
adamc@506
|
866 val fuse = {
|
adamc@506
|
867 func = Fuse.fuse,
|
adamc@506
|
868 print = MonoPrint.p_file MonoEnv.empty
|
adamc@506
|
869 }
|
adamc@506
|
870
|
adamc@572
|
871 val toFuse = transform fuse "fuse" o toMono_opt3
|
adamc@506
|
872
|
adamc@506
|
873 val toUntangle2 = transform untangle "untangle2" o toFuse
|
adamc@506
|
874
|
adamc@601
|
875 val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
|
adamc@601
|
876 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
|
adamc@916
|
877 val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2
|
adamc@1017
|
878 val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4
|
adamc@1017
|
879 val toFuse2 = transform fuse "shake2" o toMono_reduce3
|
adamc@916
|
880 val toUntangle3 = transform untangle "untangle3" o toFuse2
|
adamc@916
|
881 val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3
|
adamc@506
|
882
|
adamc@377
|
883 val pathcheck = {
|
adamc@377
|
884 func = (fn file => (PathCheck.check file; file)),
|
adamc@377
|
885 print = MonoPrint.p_file MonoEnv.empty
|
adamc@377
|
886 }
|
adamc@377
|
887
|
adamc@916
|
888 val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3
|
adamc@377
|
889
|
adamc@202
|
890 val cjrize = {
|
adamc@202
|
891 func = Cjrize.cjrize,
|
adamc@202
|
892 print = CjrPrint.p_file CjrEnv.empty
|
adamc@202
|
893 }
|
adamc@23
|
894
|
adamc@377
|
895 val toCjrize = transform cjrize "cjrize" o toPathcheck
|
adamc@29
|
896
|
adamc@643
|
897 val scriptcheck = {
|
adamc@643
|
898 func = ScriptCheck.classify,
|
adamc@643
|
899 print = CjrPrint.p_file CjrEnv.empty
|
adamc@643
|
900 }
|
adamc@643
|
901
|
adamc@643
|
902 val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize
|
adamc@643
|
903
|
adamc@282
|
904 val prepare = {
|
adamc@282
|
905 func = Prepare.prepare,
|
adamc@282
|
906 print = CjrPrint.p_file CjrEnv.empty
|
adamc@282
|
907 }
|
adamc@282
|
908
|
adamc@643
|
909 val toPrepare = transform prepare "prepare" o toScriptcheck
|
adamc@282
|
910
|
adamc@879
|
911 val checknest = {
|
adamc@879
|
912 func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f,
|
adamc@879
|
913 print = CjrPrint.p_file CjrEnv.empty
|
adamc@879
|
914 }
|
adamc@879
|
915
|
adamc@879
|
916 val toChecknest = transform checknest "checknest" o toPrepare
|
adamc@879
|
917
|
adamc@274
|
918 val sqlify = {
|
adamc@274
|
919 func = Cjrize.cjrize,
|
adamc@274
|
920 print = CjrPrint.p_sql CjrEnv.empty
|
adamc@274
|
921 }
|
adamc@274
|
922
|
adamc@274
|
923 val toSqlify = transform sqlify "sqlify" o toMono_opt2
|
adamc@274
|
924
|
adamc@764
|
925 fun compileC {cname, oname, ename, libs, profile, debug, link = link'} =
|
adamc@183
|
926 let
|
adamc@855
|
927 val proto = Settings.currentProtocol ()
|
adamc@378
|
928 val urweb_o = clibFile "urweb.o"
|
adamc@914
|
929 val memmem_o = clibFile "memmem.o"
|
adamc@378
|
930
|
adamc@949
|
931 val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -fno-inline -I " ^ Config.includ
|
adamc@832
|
932 ^ " -c " ^ cname ^ " -o " ^ oname
|
adamc@914
|
933 val link = "gcc -Werror -O3 -lm -lmhash -pthread " ^ Config.gccArgs ^ " " ^ libs ^ " " ^ urweb_o ^ " " ^ oname
|
adamc@914
|
934 ^ " " ^ memmem_o ^ " " ^ #link proto ^ " -o " ^ ename
|
adamc@502
|
935
|
adamc@502
|
936 val (compile, link) =
|
adamc@502
|
937 if profile then
|
adamc@502
|
938 (compile ^ " -pg", link ^ " -pg")
|
adamc@502
|
939 else
|
adamc@502
|
940 (compile, link)
|
adamc@742
|
941
|
adamc@742
|
942 val (compile, link) =
|
adamc@742
|
943 if debug then
|
adamc@742
|
944 (compile ^ " -g", link ^ " -g")
|
adamc@742
|
945 else
|
adamc@742
|
946 (compile, link)
|
adamc@764
|
947
|
adamc@764
|
948 val link = foldl (fn (s, link) => link ^ " " ^ s) link link'
|
adamc@183
|
949 in
|
adamc@1045
|
950 OS.Process.isSuccess (OS.Process.system compile)
|
adamc@1045
|
951 andalso OS.Process.isSuccess (OS.Process.system link)
|
adamc@183
|
952 end
|
adamc@183
|
953
|
adamc@202
|
954 fun compile job =
|
adamc@879
|
955 case run toChecknest job of
|
adamc@1045
|
956 NONE => false
|
adamc@29
|
957 | SOME file =>
|
adamc@202
|
958 let
|
adamc@274
|
959 val job = valOf (run (transform parseUrp "parseUrp") job)
|
adamc@102
|
960
|
adamc@274
|
961 val (cname, oname, cleanup) =
|
adamc@274
|
962 if #debug job then
|
adamc@457
|
963 ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
|
adamc@274
|
964 else
|
adamc@274
|
965 let
|
adamc@274
|
966 val dir = OS.FileSys.tmpName ()
|
adamc@403
|
967 val () = if OS.FileSys.access (dir, []) then
|
adamc@403
|
968 OS.FileSys.remove dir
|
adamc@403
|
969 else
|
adamc@403
|
970 ()
|
adamc@457
|
971 val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
|
adamc@457
|
972 val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
|
adamc@274
|
973 in
|
adamc@274
|
974 OS.FileSys.mkDir dir;
|
adamc@274
|
975 (cname, oname,
|
adamc@274
|
976 fn () => (OS.FileSys.remove cname;
|
adamc@274
|
977 OS.FileSys.remove oname;
|
adamc@473
|
978 OS.FileSys.rmDir dir)
|
adamc@473
|
979 handle OS.SysErr _ => OS.FileSys.rmDir dir)
|
adamc@274
|
980 end
|
adamc@274
|
981 val ename = #exe job
|
adamc@202
|
982 in
|
adamc@274
|
983 let
|
adamc@274
|
984 val outf = TextIO.openOut cname
|
adamc@274
|
985 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@432
|
986
|
adamc@432
|
987 val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
|
adamc@432
|
988 val libs =
|
adamc@432
|
989 if hasDb then
|
adamc@866
|
990 #link (Settings.currentDbms ())
|
adamc@432
|
991 else
|
adamc@432
|
992 ""
|
adamc@274
|
993 in
|
adamc@274
|
994 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
|
adamc@415
|
995 TextIO.output1 (outf, #"\n");
|
adamc@274
|
996 TextIO.closeOut outf;
|
adamc@102
|
997
|
adamc@274
|
998 case #sql job of
|
adamc@274
|
999 NONE => ()
|
adamc@274
|
1000 | SOME sql =>
|
adamc@274
|
1001 let
|
adamc@274
|
1002 val outf = TextIO.openOut sql
|
adamc@274
|
1003 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@274
|
1004 in
|
adamc@274
|
1005 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
|
adamc@274
|
1006 TextIO.closeOut outf
|
adamc@274
|
1007 end;
|
adamc@274
|
1008
|
adamc@742
|
1009 compileC {cname = cname, oname = oname, ename = ename, libs = libs,
|
adamc@1045
|
1010 profile = #profile job, debug = #debug job, link = #link job}
|
adamc@274
|
1011
|
adamc@1045
|
1012 before cleanup ()
|
adamc@274
|
1013 end
|
adamc@274
|
1014 handle ex => (((cleanup ()) handle _ => ()); raise ex)
|
adamc@202
|
1015 end
|
adamc@29
|
1016
|
adamc@1045
|
1017 fun compiler job =
|
adamc@1045
|
1018 if compile job then
|
adamc@1045
|
1019 ()
|
adamc@1045
|
1020 else
|
adamc@1045
|
1021 OS.Process.exit OS.Process.failure
|
adamc@1045
|
1022
|
adamc@1
|
1023 end
|