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@768
|
54 rewrites : Settings.rewrite list
|
adamc@270
|
55 }
|
adamc@201
|
56
|
adamc@201
|
57 type ('src, 'dst) phase = {
|
adamc@201
|
58 func : 'src -> 'dst,
|
adamc@201
|
59 print : 'dst -> Print.PD.pp_desc
|
adamc@201
|
60 }
|
adamc@201
|
61
|
adamc@201
|
62 type pmap = (string * Time.time) list
|
adamc@201
|
63
|
adamc@201
|
64 type ('src, 'dst) transform = {
|
adamc@201
|
65 func : 'src -> 'dst option,
|
adamc@201
|
66 print : 'dst -> Print.PD.pp_desc,
|
adamc@201
|
67 time : 'src * pmap -> 'dst option * pmap
|
adamc@201
|
68 }
|
adamc@201
|
69
|
adamc@201
|
70 fun transform (ph : ('src, 'dst) phase) name = {
|
adamc@201
|
71 func = fn input => let
|
adamc@201
|
72 val v = #func ph input
|
adamc@201
|
73 in
|
adamc@201
|
74 if ErrorMsg.anyErrors () then
|
adamc@201
|
75 NONE
|
adamc@201
|
76 else
|
adamc@201
|
77 SOME v
|
adamc@201
|
78 end,
|
adamc@201
|
79 print = #print ph,
|
adamc@201
|
80 time = fn (input, pmap) => let
|
adamc@201
|
81 val befor = Time.now ()
|
adamc@201
|
82 val v = #func ph input
|
adamc@201
|
83 val elapsed = Time.- (Time.now (), befor)
|
adamc@201
|
84 in
|
adamc@201
|
85 (if ErrorMsg.anyErrors () then
|
adamc@201
|
86 NONE
|
adamc@201
|
87 else
|
adamc@201
|
88 SOME v,
|
adamc@201
|
89 (name, elapsed) :: pmap)
|
adamc@201
|
90 end
|
adamc@201
|
91 }
|
adamc@201
|
92
|
adamc@270
|
93 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
|
adamc@201
|
94 func = fn input => case #func tr1 input of
|
adamc@201
|
95 NONE => NONE
|
adamc@201
|
96 | SOME v => #func tr2 v,
|
adamc@201
|
97 print = #print tr2,
|
adamc@201
|
98 time = fn (input, pmap) => let
|
adamc@201
|
99 val (ro, pmap) = #time tr1 (input, pmap)
|
adamc@201
|
100 in
|
adamc@201
|
101 case ro of
|
adamc@201
|
102 NONE => (NONE, pmap)
|
adamc@201
|
103 | SOME v => #time tr2 (v, 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@767
|
268 fun parseUrp' filename =
|
adamc@767
|
269 let
|
adamc@767
|
270 val dir = OS.Path.dir filename
|
adamc@767
|
271 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
|
adamc@767
|
272
|
adamc@767
|
273 fun relify fname =
|
adamc@767
|
274 OS.Path.concat (dir, fname)
|
adamc@767
|
275 handle OS.Path.Path => fname
|
adamc@767
|
276
|
adamc@767
|
277 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
|
adamc@767
|
278
|
adamc@767
|
279 fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir}
|
adamc@767
|
280
|
adamc@767
|
281 fun readSources acc =
|
adamc@767
|
282 case TextIO.inputLine inf of
|
adamc@767
|
283 NONE => rev acc
|
adamc@767
|
284 | SOME line =>
|
adamc@767
|
285 let
|
adamc@767
|
286 val acc = if CharVector.all Char.isSpace line then
|
adamc@767
|
287 acc
|
adamc@767
|
288 else
|
adamc@767
|
289 let
|
adamc@767
|
290 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
|
adamc@767
|
291 (String.explode line))
|
adamc@767
|
292 val fname = relify fname
|
adamc@767
|
293 in
|
adamc@767
|
294 fname :: acc
|
adamc@767
|
295 end
|
adamc@767
|
296 in
|
adamc@767
|
297 readSources acc
|
adamc@767
|
298 end
|
adamc@767
|
299
|
adamc@767
|
300 val prefix = ref NONE
|
adamc@767
|
301 val database = ref NONE
|
adamc@767
|
302 val exe = ref NONE
|
adamc@767
|
303 val sql = ref NONE
|
adamc@767
|
304 val debug = ref false
|
adamc@767
|
305 val profile = ref false
|
adamc@767
|
306 val timeout = ref NONE
|
adamc@767
|
307 val ffi = ref []
|
adamc@767
|
308 val link = ref []
|
adamc@767
|
309 val headers = ref []
|
adamc@767
|
310 val scripts = ref []
|
adamc@767
|
311 val clientToServer = ref []
|
adamc@767
|
312 val effectful = ref []
|
adamc@767
|
313 val clientOnly = ref []
|
adamc@767
|
314 val serverOnly = ref []
|
adamc@767
|
315 val jsFuncs = ref []
|
adamc@768
|
316 val rewrites = ref []
|
adamc@767
|
317 val libs = ref []
|
adamc@767
|
318
|
adamc@767
|
319 fun finish sources =
|
adamc@767
|
320 let
|
adamc@767
|
321 val job = {
|
adamc@767
|
322 prefix = Option.getOpt (!prefix, "/"),
|
adamc@767
|
323 database = !database,
|
adamc@767
|
324 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
|
adamc@767
|
325 ext = SOME "exe"}),
|
adamc@767
|
326 sql = !sql,
|
adamc@767
|
327 debug = !debug,
|
adamc@767
|
328 profile = !profile,
|
adamc@767
|
329 timeout = Option.getOpt (!timeout, 60),
|
adamc@767
|
330 ffi = rev (!ffi),
|
adamc@767
|
331 link = rev (!link),
|
adamc@767
|
332 headers = rev (!headers),
|
adamc@767
|
333 scripts = rev (!scripts),
|
adamc@767
|
334 clientToServer = rev (!clientToServer),
|
adamc@767
|
335 effectful = rev (!effectful),
|
adamc@767
|
336 clientOnly = rev (!clientOnly),
|
adamc@767
|
337 serverOnly = rev (!serverOnly),
|
adamc@767
|
338 jsFuncs = rev (!jsFuncs),
|
adamc@768
|
339 rewrites = rev (!rewrites),
|
adamc@767
|
340 sources = sources
|
adamc@767
|
341 }
|
adamc@767
|
342
|
adamc@767
|
343 fun mergeO f (old, new) =
|
adamc@767
|
344 case (old, new) of
|
adamc@767
|
345 (NONE, _) => new
|
adamc@767
|
346 | (_, NONE) => old
|
adamc@767
|
347 | (SOME v1, SOME v2) => SOME (f (v1, v2))
|
adamc@767
|
348
|
adamc@767
|
349 fun same desc = mergeO (fn (x : string, y) =>
|
adamc@767
|
350 (if x = y then
|
adamc@767
|
351 ()
|
adamc@767
|
352 else
|
adamc@767
|
353 ErrorMsg.error ("Multiple "
|
adamc@767
|
354 ^ desc ^ " values that don't agree");
|
adamc@767
|
355 x))
|
adamc@767
|
356
|
adamc@767
|
357 fun merge (old : job, new : job) = {
|
adamc@767
|
358 prefix = #prefix old,
|
adamc@767
|
359 database = #database old,
|
adamc@767
|
360 exe = #exe old,
|
adamc@767
|
361 sql = #sql old,
|
adamc@767
|
362 debug = #debug old orelse #debug new,
|
adamc@767
|
363 profile = #profile old orelse #profile new,
|
adamc@767
|
364 timeout = #timeout old,
|
adamc@767
|
365 ffi = #ffi old @ #ffi new,
|
adamc@767
|
366 link = #link old @ #link new,
|
adamc@767
|
367 headers = #headers old @ #headers new,
|
adamc@767
|
368 scripts = #scripts old @ #scripts new,
|
adamc@767
|
369 clientToServer = #clientToServer old @ #clientToServer new,
|
adamc@767
|
370 effectful = #effectful old @ #effectful new,
|
adamc@767
|
371 clientOnly = #clientOnly old @ #clientOnly new,
|
adamc@767
|
372 serverOnly = #serverOnly old @ #serverOnly new,
|
adamc@767
|
373 jsFuncs = #jsFuncs old @ #jsFuncs new,
|
adamc@768
|
374 rewrites = #rewrites old @ #rewrites new,
|
adamc@767
|
375 sources = #sources old @ #sources new
|
adamc@767
|
376 }
|
adamc@767
|
377 in
|
adamc@767
|
378 foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs)
|
adamc@767
|
379 end
|
adamc@767
|
380
|
adamc@768
|
381 fun parsePkind s =
|
adamc@768
|
382 case s of
|
adamc@768
|
383 "all" => Settings.Any
|
adamc@768
|
384 | "url" => Settings.Url
|
adamc@768
|
385 | "table" => Settings.Table
|
adamc@768
|
386 | "sequence" => Settings.Sequence
|
adamc@768
|
387 | "view" => Settings.View
|
adamc@768
|
388 | "relation" => Settings.Relation
|
adamc@768
|
389 | "cookie" => Settings.Cookie
|
adamc@768
|
390 | "style" => Settings.Style
|
adamc@768
|
391 | _ => (ErrorMsg.error "Bad path kind spec";
|
adamc@768
|
392 Settings.Any)
|
adamc@768
|
393
|
adamc@768
|
394 fun parseFrom s =
|
adamc@768
|
395 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
|
adamc@768
|
396 (Settings.Prefix, String.substring (s, 0, size s - 1))
|
adamc@768
|
397 else
|
adamc@768
|
398 (Settings.Exact, s)
|
adamc@768
|
399
|
adamc@767
|
400 fun read () =
|
adamc@767
|
401 case TextIO.inputLine inf of
|
adamc@767
|
402 NONE => finish []
|
adamc@767
|
403 | SOME "\n" => finish (readSources [])
|
adamc@767
|
404 | SOME line =>
|
adamc@767
|
405 let
|
adamc@767
|
406 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
|
adamc@767
|
407 val cmd = Substring.string (trim cmd)
|
adamc@767
|
408 val arg = Substring.string (trim arg)
|
adamc@767
|
409
|
adamc@767
|
410 fun ffiS () =
|
adamc@767
|
411 case String.fields (fn ch => ch = #".") arg of
|
adamc@767
|
412 [m, x] => (m, x)
|
adamc@767
|
413 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
|
adamc@767
|
414 ("", ""))
|
adamc@767
|
415
|
adamc@767
|
416 fun ffiM () =
|
adamc@767
|
417 case String.fields (fn ch => ch = #"=") arg of
|
adamc@767
|
418 [f, s] =>
|
adamc@767
|
419 (case String.fields (fn ch => ch = #".") f of
|
adamc@767
|
420 [m, x] => ((m, x), s)
|
adamc@767
|
421 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
|
adamc@767
|
422 (("", ""), "")))
|
adamc@767
|
423 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
|
adamc@767
|
424 (("", ""), ""))
|
adamc@767
|
425 in
|
adamc@767
|
426 case cmd of
|
adamc@767
|
427 "prefix" =>
|
adamc@767
|
428 (case !prefix of
|
adamc@767
|
429 NONE => ()
|
adamc@767
|
430 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
|
adamc@767
|
431 prefix := SOME arg)
|
adamc@767
|
432 | "database" =>
|
adamc@767
|
433 (case !database of
|
adamc@767
|
434 NONE => ()
|
adamc@767
|
435 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
|
adamc@767
|
436 database := SOME arg)
|
adamc@767
|
437 | "exe" =>
|
adamc@767
|
438 (case !exe of
|
adamc@767
|
439 NONE => ()
|
adamc@767
|
440 | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
|
adamc@767
|
441 exe := SOME (relify arg))
|
adamc@767
|
442 | "sql" =>
|
adamc@767
|
443 (case !sql of
|
adamc@767
|
444 NONE => ()
|
adamc@767
|
445 | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
|
adamc@767
|
446 sql := SOME (relify arg))
|
adamc@767
|
447 | "debug" => debug := true
|
adamc@767
|
448 | "profile" => profile := true
|
adamc@767
|
449 | "timeout" =>
|
adamc@767
|
450 (case !timeout of
|
adamc@767
|
451 NONE => ()
|
adamc@767
|
452 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
|
adamc@767
|
453 timeout := SOME (valOf (Int.fromString arg)))
|
adamc@767
|
454 | "ffi" => ffi := relify arg :: !ffi
|
adamc@767
|
455 | "link" => link := relifyA arg :: !link
|
adamc@767
|
456 | "include" => headers := relifyA arg :: !headers
|
adamc@767
|
457 | "script" => scripts := arg :: !scripts
|
adamc@767
|
458 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
|
adamc@767
|
459 | "effectful" => effectful := ffiS () :: !effectful
|
adamc@767
|
460 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
|
adamc@767
|
461 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
|
adamc@767
|
462 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
|
adamc@768
|
463 | "rewrite" =>
|
adamc@768
|
464 let
|
adamc@768
|
465 fun doit (pkind, from, to) =
|
adamc@768
|
466 let
|
adamc@768
|
467 val pkind = parsePkind pkind
|
adamc@768
|
468 val (kind, from) = parseFrom from
|
adamc@768
|
469 in
|
adamc@768
|
470 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
|
adamc@768
|
471 end
|
adamc@768
|
472 in
|
adamc@768
|
473 case String.tokens Char.isSpace arg of
|
adamc@768
|
474 [pkind, from, to] => doit (pkind, from, to)
|
adamc@768
|
475 | [pkind, from] => doit (pkind, from, "")
|
adamc@768
|
476 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
|
adamc@768
|
477 end
|
adamc@767
|
478 | "library" => libs := relify arg :: !libs
|
adamc@767
|
479 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
|
adamc@767
|
480 read ()
|
adamc@767
|
481 end
|
adamc@767
|
482
|
adamc@767
|
483 val job = read ()
|
adamc@767
|
484 in
|
adamc@767
|
485 TextIO.closeIn inf;
|
adamc@767
|
486 Settings.setUrlPrefix (#prefix job);
|
adamc@767
|
487 Settings.setTimeout (#timeout job);
|
adamc@767
|
488 Settings.setHeaders (#headers job);
|
adamc@767
|
489 Settings.setScripts (#scripts job);
|
adamc@767
|
490 Settings.setClientToServer (#clientToServer job);
|
adamc@767
|
491 Settings.setEffectful (#effectful job);
|
adamc@767
|
492 Settings.setClientOnly (#clientOnly job);
|
adamc@767
|
493 Settings.setServerOnly (#serverOnly job);
|
adamc@767
|
494 Settings.setJsFuncs (#jsFuncs job);
|
adamc@768
|
495 Settings.setRewriteRules (#rewrites job);
|
adamc@767
|
496 job
|
adamc@767
|
497 end
|
adamc@767
|
498
|
adamc@270
|
499 val parseUrp = {
|
adamc@767
|
500 func = parseUrp',
|
adamc@270
|
501 print = p_job
|
adamc@270
|
502 }
|
adamc@270
|
503
|
adamc@270
|
504 val toParseJob = transform parseUrp "parseJob"
|
adamc@270
|
505
|
adamc@56
|
506 fun capitalize "" = ""
|
adamc@56
|
507 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@56
|
508
|
adamc@201
|
509 val parse = {
|
adamc@764
|
510 func = fn {database, sources = fnames, ffi, ...} : job =>
|
adamc@201
|
511 let
|
adamc@201
|
512 fun nameOf fname = capitalize (OS.Path.file fname)
|
adamc@109
|
513
|
adamc@764
|
514 fun parseFfi fname =
|
adamc@764
|
515 let
|
adamc@764
|
516 val mname = nameOf fname
|
adamc@764
|
517 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@764
|
518
|
adamc@764
|
519 val loc = {file = urs,
|
adamc@764
|
520 first = ErrorMsg.dummyPos,
|
adamc@764
|
521 last = ErrorMsg.dummyPos}
|
adamc@764
|
522
|
adamc@764
|
523 val sgn = (Source.SgnConst (#func parseUrs urs), loc)
|
adamc@764
|
524 in
|
adamc@764
|
525 (Source.DFfiStr (mname, sgn), loc)
|
adamc@764
|
526 end
|
adamc@764
|
527
|
adamc@201
|
528 fun parseOne fname =
|
adamc@201
|
529 let
|
adamc@201
|
530 val mname = nameOf fname
|
adamc@244
|
531 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
|
adamc@244
|
532 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@56
|
533
|
adamc@201
|
534 val sgnO =
|
adamc@244
|
535 if Posix.FileSys.access (urs, []) then
|
adamc@244
|
536 SOME (Source.SgnConst (#func parseUrs urs),
|
adamc@244
|
537 {file = urs,
|
adamc@201
|
538 first = ErrorMsg.dummyPos,
|
adamc@201
|
539 last = ErrorMsg.dummyPos})
|
adamc@201
|
540 else
|
adamc@201
|
541 NONE
|
adamc@56
|
542
|
adamc@244
|
543 val loc = {file = ur,
|
adamc@201
|
544 first = ErrorMsg.dummyPos,
|
adamc@201
|
545 last = ErrorMsg.dummyPos}
|
adamc@56
|
546
|
adamc@244
|
547 val ds = #func parseUr ur
|
adamc@201
|
548 in
|
adamc@201
|
549 (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
|
adamc@201
|
550 end
|
adamc@56
|
551
|
adamc@764
|
552 val dsFfi = map parseFfi ffi
|
adamc@201
|
553 val ds = map parseOne fnames
|
adamc@201
|
554 in
|
adamc@201
|
555 let
|
adamc@201
|
556 val final = nameOf (List.last fnames)
|
adamc@271
|
557
|
adamc@764
|
558 val ds = dsFfi @ ds
|
adamc@764
|
559 @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
|
adamc@201
|
560 in
|
adamc@271
|
561 case database of
|
adamc@271
|
562 NONE => ds
|
adamc@271
|
563 | SOME s => (Source.DDatabase s, ErrorMsg.dummySpan) :: ds
|
adamc@201
|
564 end handle Empty => ds
|
adamc@201
|
565 end,
|
adamc@201
|
566 print = SourcePrint.p_file
|
adamc@201
|
567 }
|
adamc@56
|
568
|
adamc@270
|
569 val toParse = transform parse "parse" o toParseJob
|
adamc@38
|
570
|
adamc@378
|
571 fun libFile s = OS.Path.joinDirFile {dir = Config.libUr,
|
adamc@378
|
572 file = s}
|
adamc@378
|
573 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
|
adamc@378
|
574 file = s}
|
adamc@378
|
575
|
adamc@201
|
576 val elaborate = {
|
adamc@201
|
577 func = fn file => let
|
adamc@378
|
578 val basis = #func parseUrs (libFile "basis.urs")
|
adamc@378
|
579 val topSgn = #func parseUrs (libFile "top.urs")
|
adamc@378
|
580 val topStr = #func parseUr (libFile "top.ur")
|
adamc@201
|
581 in
|
adamc@325
|
582 Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
|
adamc@201
|
583 end,
|
adamc@201
|
584 print = ElabPrint.p_file ElabEnv.empty
|
adamc@201
|
585 }
|
adamc@5
|
586
|
adamc@270
|
587 val toElaborate = transform elaborate "elaborate" o toParse
|
adamc@201
|
588
|
adamc@448
|
589 val unnest = {
|
adamc@448
|
590 func = Unnest.unnest,
|
adamc@448
|
591 print = ElabPrint.p_file ElabEnv.empty
|
adamc@448
|
592 }
|
adamc@448
|
593
|
adamc@448
|
594 val toUnnest = transform unnest "unnest" o toElaborate
|
adamc@448
|
595
|
adamc@313
|
596 val termination = {
|
adamc@313
|
597 func = (fn file => (Termination.check file; file)),
|
adamc@313
|
598 print = ElabPrint.p_file ElabEnv.empty
|
adamc@313
|
599 }
|
adamc@313
|
600
|
adamc@448
|
601 val toTermination = transform termination "termination" o toUnnest
|
adamc@313
|
602
|
adamc@201
|
603 val explify = {
|
adamc@201
|
604 func = Explify.explify,
|
adamc@201
|
605 print = ExplPrint.p_file ExplEnv.empty
|
adamc@201
|
606 }
|
adamc@201
|
607
|
adamc@625
|
608 val toExplify = transform explify "explify" o toUnnest
|
adamc@201
|
609
|
adamc@201
|
610 val corify = {
|
adamc@201
|
611 func = Corify.corify,
|
adamc@201
|
612 print = CorePrint.p_file CoreEnv.empty
|
adamc@201
|
613 }
|
adamc@201
|
614
|
adamc@270
|
615 val toCorify = transform corify "corify" o toExplify
|
adamc@201
|
616
|
adamc@482
|
617 (*val reduce_local = {
|
adamc@482
|
618 func = ReduceLocal.reduce,
|
adamc@482
|
619 print = CorePrint.p_file CoreEnv.empty
|
adamc@482
|
620 }
|
adamc@482
|
621
|
adamc@482
|
622 val toReduce_local = transform reduce_local "reduce_local" o toCorify*)
|
adamc@482
|
623
|
adamc@443
|
624 val especialize = {
|
adamc@443
|
625 func = ESpecialize.specialize,
|
adamc@443
|
626 print = CorePrint.p_file CoreEnv.empty
|
adamc@443
|
627 }
|
adamc@443
|
628
|
adamc@443
|
629 val toEspecialize = transform especialize "especialize" o toCorify
|
adamc@443
|
630
|
adamc@454
|
631 val core_untangle = {
|
adamc@454
|
632 func = CoreUntangle.untangle,
|
adamc@454
|
633 print = CorePrint.p_file CoreEnv.empty
|
adamc@454
|
634 }
|
adamc@454
|
635
|
adamc@454
|
636 val toCore_untangle = transform core_untangle "core_untangle" o toEspecialize
|
adamc@454
|
637
|
adamc@202
|
638 val shake = {
|
adamc@202
|
639 func = Shake.shake,
|
adamc@202
|
640 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
641 }
|
adamc@39
|
642
|
adamc@454
|
643 val toShake1 = transform shake "shake1" o toCore_untangle
|
adamc@110
|
644
|
adamc@607
|
645 val rpcify = {
|
adamc@607
|
646 func = Rpcify.frob,
|
adamc@607
|
647 print = CorePrint.p_file CoreEnv.empty
|
adamc@607
|
648 }
|
adamc@607
|
649
|
adamc@607
|
650 val toRpcify = transform rpcify "rpcify" o toShake1
|
adamc@607
|
651
|
adamc@642
|
652 val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
|
adamc@642
|
653 val toShake2 = transform shake "shake2" o toCore_untangle2
|
adamc@642
|
654
|
adamc@202
|
655 val tag = {
|
adamc@202
|
656 func = Tag.tag,
|
adamc@202
|
657 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
658 }
|
adamc@193
|
659
|
adamc@642
|
660 val toTag = transform tag "tag" o toCore_untangle2
|
adamc@20
|
661
|
adamc@202
|
662 val reduce = {
|
adamc@202
|
663 func = Reduce.reduce,
|
adamc@202
|
664 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
665 }
|
adamc@25
|
666
|
adamc@692
|
667 val toReduce = transform reduce "reduce" o toTag
|
adamc@23
|
668
|
adamc@315
|
669 val unpoly = {
|
adamc@315
|
670 func = Unpoly.unpoly,
|
adamc@315
|
671 print = CorePrint.p_file CoreEnv.empty
|
adamc@315
|
672 }
|
adamc@315
|
673
|
adamc@315
|
674 val toUnpoly = transform unpoly "unpoly" o toReduce
|
adamc@315
|
675
|
adamc@202
|
676 val specialize = {
|
adamc@202
|
677 func = Specialize.specialize,
|
adamc@202
|
678 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
679 }
|
adamc@132
|
680
|
adamc@315
|
681 val toSpecialize = transform specialize "specialize" o toUnpoly
|
adamc@131
|
682
|
adamc@642
|
683 val toShake3 = transform shake "shake3" o toSpecialize
|
adamc@133
|
684
|
adamc@692
|
685 val marshalcheck = {
|
adamc@692
|
686 func = (fn file => (MarshalCheck.check file; file)),
|
adamc@692
|
687 print = CorePrint.p_file CoreEnv.empty
|
adamc@692
|
688 }
|
adamc@692
|
689
|
adamc@692
|
690 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake3
|
adamc@692
|
691
|
adamc@732
|
692 val effectize = {
|
adamc@732
|
693 func = Effective.effectize,
|
adamc@732
|
694 print = CorePrint.p_file CoreEnv.empty
|
adamc@732
|
695 }
|
adamc@732
|
696
|
adamc@732
|
697 val toEffectize = transform effectize "effectize" o toMarshalcheck
|
adamc@732
|
698
|
adamc@202
|
699 val monoize = {
|
adamc@202
|
700 func = Monoize.monoize CoreEnv.empty,
|
adamc@202
|
701 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
702 }
|
adamc@134
|
703
|
adamc@732
|
704 val toMonoize = transform monoize "monoize" o toEffectize
|
adamc@96
|
705
|
adamc@202
|
706 val mono_opt = {
|
adamc@202
|
707 func = MonoOpt.optimize,
|
adamc@202
|
708 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
709 }
|
adamc@29
|
710
|
adamc@270
|
711 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
|
adamc@5
|
712
|
adamc@202
|
713 val untangle = {
|
adamc@202
|
714 func = Untangle.untangle,
|
adamc@202
|
715 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
716 }
|
adamc@1
|
717
|
adamc@270
|
718 val toUntangle = transform untangle "untangle" o toMono_opt1
|
adamc@38
|
719
|
adamc@202
|
720 val mono_reduce = {
|
adamc@202
|
721 func = MonoReduce.reduce,
|
adamc@202
|
722 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
723 }
|
adamc@16
|
724
|
adamc@270
|
725 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
|
adamc@39
|
726
|
adamc@202
|
727 val mono_shake = {
|
adamc@202
|
728 func = MonoShake.shake,
|
adamc@202
|
729 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
730 }
|
adamc@110
|
731
|
adamc@270
|
732 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
|
adamc@193
|
733
|
adamc@572
|
734 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
|
adamc@572
|
735
|
adamc@567
|
736 val jscomp = {
|
adamc@567
|
737 func = JsComp.process,
|
adamc@567
|
738 print = MonoPrint.p_file MonoEnv.empty
|
adamc@567
|
739 }
|
adamc@567
|
740
|
adamc@572
|
741 val toJscomp = transform jscomp "jscomp" o toMono_opt2
|
adamc@567
|
742
|
adamc@572
|
743 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
|
adamc@20
|
744
|
adamc@506
|
745 val fuse = {
|
adamc@506
|
746 func = Fuse.fuse,
|
adamc@506
|
747 print = MonoPrint.p_file MonoEnv.empty
|
adamc@506
|
748 }
|
adamc@506
|
749
|
adamc@572
|
750 val toFuse = transform fuse "fuse" o toMono_opt3
|
adamc@506
|
751
|
adamc@506
|
752 val toUntangle2 = transform untangle "untangle2" o toFuse
|
adamc@506
|
753
|
adamc@601
|
754 val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
|
adamc@601
|
755 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
|
adamc@506
|
756
|
adamc@377
|
757 val pathcheck = {
|
adamc@377
|
758 func = (fn file => (PathCheck.check file; file)),
|
adamc@377
|
759 print = MonoPrint.p_file MonoEnv.empty
|
adamc@377
|
760 }
|
adamc@377
|
761
|
adamc@506
|
762 val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2
|
adamc@377
|
763
|
adamc@202
|
764 val cjrize = {
|
adamc@202
|
765 func = Cjrize.cjrize,
|
adamc@202
|
766 print = CjrPrint.p_file CjrEnv.empty
|
adamc@202
|
767 }
|
adamc@23
|
768
|
adamc@377
|
769 val toCjrize = transform cjrize "cjrize" o toPathcheck
|
adamc@29
|
770
|
adamc@643
|
771 val scriptcheck = {
|
adamc@643
|
772 func = ScriptCheck.classify,
|
adamc@643
|
773 print = CjrPrint.p_file CjrEnv.empty
|
adamc@643
|
774 }
|
adamc@643
|
775
|
adamc@643
|
776 val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize
|
adamc@643
|
777
|
adamc@282
|
778 val prepare = {
|
adamc@282
|
779 func = Prepare.prepare,
|
adamc@282
|
780 print = CjrPrint.p_file CjrEnv.empty
|
adamc@282
|
781 }
|
adamc@282
|
782
|
adamc@643
|
783 val toPrepare = transform prepare "prepare" o toScriptcheck
|
adamc@282
|
784
|
adamc@274
|
785 val sqlify = {
|
adamc@274
|
786 func = Cjrize.cjrize,
|
adamc@274
|
787 print = CjrPrint.p_sql CjrEnv.empty
|
adamc@274
|
788 }
|
adamc@274
|
789
|
adamc@274
|
790 val toSqlify = transform sqlify "sqlify" o toMono_opt2
|
adamc@274
|
791
|
adamc@764
|
792 fun compileC {cname, oname, ename, libs, profile, debug, link = link'} =
|
adamc@183
|
793 let
|
adamc@378
|
794 val urweb_o = clibFile "urweb.o"
|
adamc@378
|
795 val driver_o = clibFile "driver.o"
|
adamc@378
|
796
|
adamc@435
|
797 val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname
|
adamc@734
|
798 val link = "gcc -Werror -O3 -lm -lmhash -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename
|
adamc@502
|
799
|
adamc@502
|
800 val (compile, link) =
|
adamc@502
|
801 if profile then
|
adamc@502
|
802 (compile ^ " -pg", link ^ " -pg")
|
adamc@502
|
803 else
|
adamc@502
|
804 (compile, link)
|
adamc@742
|
805
|
adamc@742
|
806 val (compile, link) =
|
adamc@742
|
807 if debug then
|
adamc@742
|
808 (compile ^ " -g", link ^ " -g")
|
adamc@742
|
809 else
|
adamc@742
|
810 (compile, link)
|
adamc@764
|
811
|
adamc@764
|
812 val link = foldl (fn (s, link) => link ^ " " ^ s) link link'
|
adamc@183
|
813 in
|
adamc@183
|
814 if not (OS.Process.isSuccess (OS.Process.system compile)) then
|
adamc@183
|
815 print "C compilation failed\n"
|
adamc@183
|
816 else if not (OS.Process.isSuccess (OS.Process.system link)) then
|
adamc@186
|
817 print "C linking failed\n"
|
adamc@183
|
818 else
|
adamc@673
|
819 ()
|
adamc@183
|
820 end
|
adamc@183
|
821
|
adamc@202
|
822 fun compile job =
|
adamc@282
|
823 case run toPrepare job of
|
adamc@244
|
824 NONE => print "Ur compilation failed\n"
|
adamc@29
|
825 | SOME file =>
|
adamc@202
|
826 let
|
adamc@274
|
827 val job = valOf (run (transform parseUrp "parseUrp") job)
|
adamc@102
|
828
|
adamc@274
|
829 val (cname, oname, cleanup) =
|
adamc@274
|
830 if #debug job then
|
adamc@457
|
831 ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
|
adamc@274
|
832 else
|
adamc@274
|
833 let
|
adamc@274
|
834 val dir = OS.FileSys.tmpName ()
|
adamc@403
|
835 val () = if OS.FileSys.access (dir, []) then
|
adamc@403
|
836 OS.FileSys.remove dir
|
adamc@403
|
837 else
|
adamc@403
|
838 ()
|
adamc@457
|
839 val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
|
adamc@457
|
840 val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
|
adamc@274
|
841 in
|
adamc@274
|
842 OS.FileSys.mkDir dir;
|
adamc@274
|
843 (cname, oname,
|
adamc@274
|
844 fn () => (OS.FileSys.remove cname;
|
adamc@274
|
845 OS.FileSys.remove oname;
|
adamc@473
|
846 OS.FileSys.rmDir dir)
|
adamc@473
|
847 handle OS.SysErr _ => OS.FileSys.rmDir dir)
|
adamc@274
|
848 end
|
adamc@274
|
849 val ename = #exe job
|
adamc@202
|
850 in
|
adamc@274
|
851 let
|
adamc@274
|
852 val outf = TextIO.openOut cname
|
adamc@274
|
853 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@432
|
854
|
adamc@432
|
855 val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
|
adamc@432
|
856 val libs =
|
adamc@432
|
857 if hasDb then
|
adamc@432
|
858 "-lpq"
|
adamc@432
|
859 else
|
adamc@432
|
860 ""
|
adamc@274
|
861 in
|
adamc@274
|
862 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
|
adamc@415
|
863 TextIO.output1 (outf, #"\n");
|
adamc@274
|
864 TextIO.closeOut outf;
|
adamc@102
|
865
|
adamc@274
|
866 case #sql job of
|
adamc@274
|
867 NONE => ()
|
adamc@274
|
868 | SOME sql =>
|
adamc@274
|
869 let
|
adamc@274
|
870 val outf = TextIO.openOut sql
|
adamc@274
|
871 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@274
|
872 in
|
adamc@274
|
873 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
|
adamc@274
|
874 TextIO.closeOut outf
|
adamc@274
|
875 end;
|
adamc@274
|
876
|
adamc@742
|
877 compileC {cname = cname, oname = oname, ename = ename, libs = libs,
|
adamc@764
|
878 profile = #profile job, debug = #debug job, link = #link job};
|
adamc@274
|
879
|
adamc@274
|
880 cleanup ()
|
adamc@274
|
881 end
|
adamc@274
|
882 handle ex => (((cleanup ()) handle _ => ()); raise ex)
|
adamc@202
|
883 end
|
adamc@29
|
884
|
adamc@1
|
885 end
|