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