adam@2067
|
1 (* Copyright (c) 2008-2012, 2014, 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
|
ziv@2202
|
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
|
ziv@2202
|
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,
|
adam@1725
|
47 linker : string option,
|
adamc@765
|
48 headers : string list,
|
adamc@766
|
49 scripts : string list,
|
adamc@765
|
50 clientToServer : Settings.ffi list,
|
adamc@765
|
51 effectful : Settings.ffi list,
|
adamc@1171
|
52 benignEffectful : Settings.ffi list,
|
adamc@765
|
53 clientOnly : Settings.ffi list,
|
adamc@765
|
54 serverOnly : Settings.ffi list,
|
adamc@768
|
55 jsFuncs : (Settings.ffi * string) list,
|
adamc@769
|
56 rewrites : Settings.rewrite list,
|
adamc@769
|
57 filterUrl : Settings.rule list,
|
adamc@866
|
58 filterMime : Settings.rule list,
|
adam@1465
|
59 filterRequest : Settings.rule list,
|
adam@1465
|
60 filterResponse : Settings.rule list,
|
adam@1799
|
61 filterEnv : Settings.rule list,
|
adamc@866
|
62 protocol : string option,
|
adamc@1164
|
63 dbms : string option,
|
adamc@1183
|
64 sigFile : string option,
|
adam@1294
|
65 safeGets : string list,
|
adam@1332
|
66 onError : (string * string list * string) option,
|
adam@1332
|
67 minHeap : int
|
adamc@270
|
68 }
|
adamc@201
|
69
|
adamc@201
|
70 type ('src, 'dst) phase = {
|
adamc@201
|
71 func : 'src -> 'dst,
|
adamc@201
|
72 print : 'dst -> Print.PD.pp_desc
|
adamc@201
|
73 }
|
adamc@201
|
74
|
adamc@201
|
75 type pmap = (string * Time.time) list
|
adamc@201
|
76
|
adamc@201
|
77 type ('src, 'dst) transform = {
|
adamc@201
|
78 func : 'src -> 'dst option,
|
adamc@201
|
79 print : 'dst -> Print.PD.pp_desc,
|
adamc@201
|
80 time : 'src * pmap -> 'dst option * pmap
|
adamc@201
|
81 }
|
adamc@201
|
82
|
adamc@1079
|
83 val debug = ref false
|
adam@1677
|
84 val dumpSource = ref false
|
adamc@1240
|
85 val doIflow = ref false
|
adamc@1079
|
86
|
adam@1677
|
87 val doDumpSource = ref (fn () => ())
|
adam@1677
|
88
|
adam@1961
|
89 val stop = ref (NONE : string option)
|
adam@1961
|
90 fun setStop s = stop := SOME s
|
adam@1961
|
91
|
adamc@201
|
92 fun transform (ph : ('src, 'dst) phase) name = {
|
adamc@201
|
93 func = fn input => let
|
adamc@1079
|
94 val () = if !debug then
|
adamc@1079
|
95 print ("Starting " ^ name ^ "....\n")
|
adamc@1079
|
96 else
|
adamc@1079
|
97 ()
|
adamc@201
|
98 val v = #func ph input
|
adamc@201
|
99 in
|
adamc@1079
|
100 if !debug then
|
adamc@1079
|
101 print ("Finished " ^ name ^ ".\n")
|
adamc@1079
|
102 else
|
adamc@1079
|
103 ();
|
adamc@201
|
104 if ErrorMsg.anyErrors () then
|
adam@1677
|
105 (!doDumpSource ();
|
adam@1677
|
106 doDumpSource := (fn () => ());
|
adam@1677
|
107 NONE)
|
adam@1961
|
108 else if !stop = SOME name then
|
adam@1961
|
109 (Print.eprint (#print ph v);
|
adam@1961
|
110 ErrorMsg.error ("Stopped compilation after phase " ^ name);
|
adam@1961
|
111 NONE)
|
adamc@201
|
112 else
|
adam@1677
|
113 (if !dumpSource then
|
adam@1677
|
114 doDumpSource := (fn () => Print.eprint (#print ph v))
|
adam@1677
|
115 else
|
adam@1677
|
116 ();
|
adam@1677
|
117 SOME v)
|
adamc@201
|
118 end,
|
adamc@201
|
119 print = #print ph,
|
adamc@201
|
120 time = fn (input, pmap) => let
|
adamc@1186
|
121 val () = if !debug then
|
adamc@1186
|
122 print ("Starting " ^ name ^ "....\n")
|
adamc@1186
|
123 else
|
adamc@1186
|
124 ()
|
adamc@201
|
125 val befor = Time.now ()
|
adamc@201
|
126 val v = #func ph input
|
adamc@201
|
127 val elapsed = Time.- (Time.now (), befor)
|
adamc@201
|
128 in
|
adamc@1186
|
129 if !debug then
|
adamc@1186
|
130 print ("Finished " ^ name ^ ".\n")
|
adamc@1186
|
131 else
|
adamc@1186
|
132 ();
|
adamc@201
|
133 (if ErrorMsg.anyErrors () then
|
adamc@201
|
134 NONE
|
adamc@201
|
135 else
|
adamc@201
|
136 SOME v,
|
adamc@201
|
137 (name, elapsed) :: pmap)
|
adamc@201
|
138 end
|
adamc@201
|
139 }
|
adamc@201
|
140
|
adamc@346
|
141 fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
|
adamc@346
|
142 ignore (#func tr x))
|
adamc@346
|
143
|
adamc@280
|
144 fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
|
adamc@280
|
145 #func tr x)
|
adamc@201
|
146
|
adamc@201
|
147 fun runPrint (tr : ('src, 'dst) transform) input =
|
adamc@280
|
148 (ErrorMsg.resetErrors ();
|
adamc@280
|
149 case #func tr input of
|
adamc@280
|
150 NONE => print "Failure\n"
|
adamc@280
|
151 | SOME v =>
|
adamc@280
|
152 (print "Success\n";
|
adamc@280
|
153 Print.print (#print tr v);
|
adamc@280
|
154 print "\n"))
|
adamc@201
|
155
|
adam@1362
|
156 fun runPrintToFile (tr : ('src, 'dst) transform) input fname =
|
adam@1362
|
157 (ErrorMsg.resetErrors ();
|
adam@1362
|
158 case #func tr input of
|
adam@1362
|
159 NONE => print "Failure\n"
|
adam@1362
|
160 | SOME v =>
|
adam@1362
|
161 let
|
adam@1362
|
162 val outf = TextIO.openOut fname
|
adam@1362
|
163 val str = Print.openOut {dst = outf, wid = 80}
|
adam@1362
|
164 in
|
adam@1362
|
165 print "Success\n";
|
adam@1362
|
166 Print.fprint str (#print tr v);
|
adam@1362
|
167 Print.PD.PPS.closeStream str;
|
adam@1362
|
168 TextIO.closeOut outf
|
adam@1362
|
169 end)
|
adam@1362
|
170
|
adamc@201
|
171 fun time (tr : ('src, 'dst) transform) input =
|
adamc@55
|
172 let
|
adamc@201
|
173 val (_, pmap) = #time tr (input, [])
|
adamc@201
|
174 in
|
adamc@201
|
175 app (fn (name, time) =>
|
adamc@201
|
176 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
177 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
178 print "\n"
|
adamc@201
|
179 end
|
adamc@55
|
180
|
adamc@201
|
181 fun timePrint (tr : ('src, 'dst) transform) input =
|
adamc@201
|
182 let
|
adamc@201
|
183 val (ro, pmap) = #time tr (input, [])
|
adamc@55
|
184 in
|
adamc@201
|
185 app (fn (name, time) =>
|
adamc@201
|
186 print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap);
|
adamc@201
|
187 print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n");
|
adamc@201
|
188 print "\n";
|
adamc@201
|
189 case ro of
|
adamc@201
|
190 NONE => print "Failure\n"
|
adamc@201
|
191 | SOME v =>
|
adamc@201
|
192 (print "Success\n";
|
adamc@201
|
193 Print.print (#print tr v);
|
adamc@201
|
194 print "\n")
|
adamc@55
|
195 end
|
adamc@55
|
196
|
adam@1362
|
197 fun runPrintCoreFuncs (tr : ('src, Core.file) transform) input =
|
adam@1362
|
198 (ErrorMsg.resetErrors ();
|
adam@1362
|
199 case #func tr input of
|
adam@1362
|
200 NONE => print "Failure\n"
|
adam@1362
|
201 | SOME file =>
|
adam@1362
|
202 (print "Success\n";
|
adam@1362
|
203 app (fn (d, _) =>
|
adam@1362
|
204 case d of
|
adam@1362
|
205 Core.DVal (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)
|
adam@1362
|
206 | Core.DValRec xts => app (fn (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)) xts
|
adam@1362
|
207 | _ => ()) file))
|
adam@1362
|
208
|
adamc@244
|
209 val parseUrs =
|
adamc@201
|
210 {func = fn filename => let
|
adamc@201
|
211 val fname = OS.FileSys.tmpName ()
|
adamc@201
|
212 val outf = TextIO.openOut fname
|
adamc@201
|
213 val () = TextIO.output (outf, "sig\n")
|
adamc@201
|
214 val inf = TextIO.openIn filename
|
adamc@201
|
215 fun loop () =
|
adamc@201
|
216 case TextIO.inputLine inf of
|
adamc@201
|
217 NONE => ()
|
adamc@201
|
218 | SOME line => (TextIO.output (outf, line);
|
adamc@201
|
219 loop ())
|
adamc@201
|
220 val () = loop ()
|
adamc@201
|
221 val () = TextIO.closeIn inf
|
adamc@201
|
222 val () = TextIO.closeOut outf
|
adamc@201
|
223
|
adamc@201
|
224 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
225 ErrorMsg.resetPositioning filename;
|
adamc@201
|
226 Lex.UserDeclarations.initialize ())
|
adamc@201
|
227 val file = TextIO.openIn fname
|
adamc@201
|
228 fun get _ = TextIO.input file
|
adamc@201
|
229 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
230 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
231 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
232 in
|
adamc@201
|
233 TextIO.closeIn file;
|
adamc@201
|
234 case absyn of
|
adamc@201
|
235 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis
|
adamc@201
|
236 | _ => (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
237 first = {line = 0,
|
adamc@201
|
238 char = 0},
|
adamc@201
|
239 last = {line = 0,
|
adamc@201
|
240 char = 0}} "Not a signature";
|
adamc@201
|
241 [])
|
adamc@201
|
242 end
|
adamc@201
|
243 handle LrParser.ParseError => [],
|
adamc@201
|
244 print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item}
|
adamc@55
|
245
|
adamc@1
|
246 (* The main parsing routine *)
|
adamc@244
|
247 val parseUr = {
|
adamc@201
|
248 func = fn filename =>
|
adamc@201
|
249 let
|
adamc@201
|
250 val () = (ErrorMsg.resetErrors ();
|
adamc@201
|
251 ErrorMsg.resetPositioning filename;
|
adamc@201
|
252 Lex.UserDeclarations.initialize ())
|
adamc@201
|
253 val file = TextIO.openIn filename
|
adamc@201
|
254 fun get _ = TextIO.input file
|
adamc@201
|
255 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
|
adamc@201
|
256 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
|
adamc@244
|
257 val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ())
|
adamc@201
|
258 in
|
adamc@201
|
259 TextIO.closeIn file;
|
adamc@201
|
260 case absyn of
|
adamc@201
|
261 [(Source.DSgn ("?", _), _)] =>
|
adamc@201
|
262 (ErrorMsg.errorAt {file = filename,
|
adamc@201
|
263 first = {line = 0,
|
adamc@201
|
264 char = 0},
|
adamc@201
|
265 last = {line = 0,
|
adamc@201
|
266 char = 0}} "File starts with 'sig'";
|
adamc@201
|
267 [])
|
adamc@201
|
268 | _ => absyn
|
adamc@201
|
269 end
|
adamc@201
|
270 handle LrParser.ParseError => [],
|
ziv@2202
|
271 print = SourcePrint.p_file}
|
adamc@56
|
272
|
adamc@768
|
273 fun p_job ({prefix, database, exe, sql, sources, debug, profile,
|
adamc@768
|
274 timeout, ffi, link, headers, scripts,
|
adamc@1171
|
275 clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
|
adamc@270
|
276 let
|
adamc@270
|
277 open Print.PD
|
adamc@270
|
278 open Print
|
adamc@765
|
279
|
adamc@765
|
280 fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
|
adamc@765
|
281 box [string name, space, string m, string ".", string s, newline])
|
adamc@270
|
282 in
|
adamc@274
|
283 box [if debug then
|
adamc@274
|
284 box [string "DEBUG", newline]
|
adamc@274
|
285 else
|
adamc@274
|
286 box [],
|
adamc@502
|
287 if profile then
|
adamc@502
|
288 box [string "PROFILE", newline]
|
adamc@502
|
289 else
|
adamc@502
|
290 box [],
|
adamc@274
|
291 case database of
|
adamc@270
|
292 NONE => string "No database."
|
adamc@270
|
293 | SOME db => string ("Database: " ^ db),
|
adamc@270
|
294 newline,
|
adamc@274
|
295 string "Exe: ",
|
adamc@274
|
296 string exe,
|
adamc@274
|
297 newline,
|
adamc@274
|
298 case sql of
|
adamc@274
|
299 NONE => string "No SQL file."
|
adamc@274
|
300 | SOME sql => string ("SQL fle: " ^ sql),
|
adamc@673
|
301 newline,
|
adamc@673
|
302 string "Timeout: ",
|
adamc@673
|
303 string (Int.toString timeout),
|
adamc@673
|
304 newline,
|
adamc@764
|
305 p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
|
adamc@764
|
306 p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
|
adamc@766
|
307 p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts,
|
adamc@764
|
308 p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
|
adamc@765
|
309 p_ffi "ClientToServer" clientToServer,
|
adamc@765
|
310 p_ffi "Effectful" effectful,
|
adamc@1171
|
311 p_ffi "BenignEffectful" benignEffectful,
|
adamc@765
|
312 p_ffi "ClientOnly" clientOnly,
|
adamc@765
|
313 p_ffi "ServerOnly" serverOnly,
|
adamc@765
|
314 p_list_sep (box []) (fn ((m, s), s') =>
|
adamc@765
|
315 box [string "JsFunc", space, string m, string ".", string s,
|
adamc@765
|
316 space, string "=", space, string s', newline]) jsFuncs,
|
adamc@270
|
317 string "Sources:",
|
adamc@270
|
318 p_list string sources,
|
adamc@270
|
319 newline]
|
adamc@270
|
320 end
|
adamc@270
|
321
|
adamc@270
|
322 fun trim s =
|
adamc@270
|
323 let
|
adamc@270
|
324 val (_, s) = Substring.splitl Char.isSpace s
|
adamc@270
|
325 val (s, _) = Substring.splitr Char.isSpace s
|
adamc@270
|
326 in
|
adamc@270
|
327 s
|
adamc@270
|
328 end
|
adamc@270
|
329
|
adam@1433
|
330 val trimS = Substring.string o trim o Substring.full
|
adam@1433
|
331
|
adamc@794
|
332 structure M = BinaryMapFn(struct
|
adamc@794
|
333 type ord_key = string
|
adamc@794
|
334 val compare = String.compare
|
adamc@794
|
335 end)
|
adamc@794
|
336
|
ezyang@1739
|
337 (* XXX ezyang: pathmap gets initialized /really early/, before
|
ezyang@1739
|
338 * we do any options parsing. So libUr will always point to the
|
ezyang@1739
|
339 * default. We override it explicitly in enableBoot *)
|
ezyang@1739
|
340 val pathmap = ref (M.insert (M.empty, "", Settings.libUr ()))
|
adamc@1089
|
341
|
adamc@1089
|
342 fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v)
|
adamc@1089
|
343
|
ezyang@1739
|
344 (* XXX ezyang: this is not right; it probably doesn't work in
|
ezyang@1739
|
345 * the case of separate build and src trees *)
|
ezyang@1739
|
346 fun enableBoot () =
|
ezyang@1739
|
347 (Settings.configBin := OS.Path.joinDirFile {dir = Config.builddir, file = "bin"};
|
ezyang@1739
|
348 Settings.configSrcLib := OS.Path.joinDirFile {dir = Config.builddir, file = "lib"};
|
ezyang@1739
|
349 (* joinDirFile is annoying... (ArcError; it doesn't like
|
ezyang@1739
|
350 * slashes in file) *)
|
ezyang@1739
|
351 Settings.configLib := Config.builddir ^ "/src/c/.libs";
|
ezyang@1739
|
352 Settings.configInclude := OS.Path.joinDirFile {dir = Config.builddir ^ "/include", file = "urweb"};
|
ezyang@1739
|
353 Settings.configSitelisp := Config.builddir ^ "/src/elisp";
|
ezyang@1739
|
354 addPath ("", Settings.libUr ()))
|
ezyang@1739
|
355
|
adam@1296
|
356 fun capitalize "" = ""
|
adam@1296
|
357 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adam@1296
|
358
|
adam@1296
|
359 fun institutionalizeJob (job : job) =
|
adam@1483
|
360 (Settings.setDebug (#debug job);
|
adam@1483
|
361 Settings.setUrlPrefix (#prefix job);
|
adam@1296
|
362 Settings.setTimeout (#timeout job);
|
adam@1296
|
363 Settings.setHeaders (#headers job);
|
adam@1296
|
364 Settings.setScripts (#scripts job);
|
adam@1296
|
365 Settings.setClientToServer (#clientToServer job);
|
adam@1296
|
366 Settings.setEffectful (#effectful job);
|
adam@1296
|
367 Settings.setBenignEffectful (#benignEffectful job);
|
adam@1296
|
368 Settings.setClientOnly (#clientOnly job);
|
adam@1296
|
369 Settings.setServerOnly (#serverOnly job);
|
adam@1296
|
370 Settings.setJsFuncs (#jsFuncs job);
|
adam@1296
|
371 Settings.setRewriteRules (#rewrites job);
|
adam@1296
|
372 Settings.setUrlRules (#filterUrl job);
|
adam@1296
|
373 Settings.setMimeRules (#filterMime job);
|
adam@1465
|
374 Settings.setRequestHeaderRules (#filterRequest job);
|
adam@1465
|
375 Settings.setResponseHeaderRules (#filterResponse job);
|
adam@1799
|
376 Settings.setEnvVarRules (#filterEnv job);
|
adam@1296
|
377 Option.app Settings.setProtocol (#protocol job);
|
adam@1296
|
378 Option.app Settings.setDbms (#dbms job);
|
adam@1296
|
379 Settings.setSafeGets (#safeGets job);
|
adam@1332
|
380 Settings.setOnError (#onError job);
|
adam@1408
|
381 Settings.setMinHeap (#minHeap job);
|
adam@1408
|
382 Settings.setSigFile (#sigFile job))
|
adam@1296
|
383
|
adam@1603
|
384 datatype commentableLine =
|
adam@1603
|
385 EndOfFile
|
adam@1603
|
386 | OnlyComment
|
adam@1603
|
387 | Content of string
|
adam@1603
|
388
|
adam@1331
|
389 fun inputCommentableLine inf =
|
adam@1603
|
390 case TextIO.inputLine inf of
|
adam@1603
|
391 NONE => EndOfFile
|
adam@1603
|
392 | SOME s =>
|
adam@1603
|
393 let
|
adam@1603
|
394 val (befor, after) = Substring.splitl (fn ch => ch <> #"#") (Substring.full s)
|
adam@1603
|
395 in
|
adam@1603
|
396 if not (Substring.isEmpty after)
|
adam@1603
|
397 andalso Substring.foldl (fn (ch, b) => b andalso Char.isSpace ch) true befor then
|
adam@1603
|
398 OnlyComment
|
adam@1603
|
399 else
|
adam@1603
|
400 let
|
adam@1603
|
401 val s = #1 (Substring.splitr (not o Char.isSpace) befor)
|
adam@1603
|
402 in
|
adam@1603
|
403 Content (Substring.string (if Substring.size s > 0 andalso Char.isSpace (Substring.sub (s, Substring.size s - 1)) then
|
adam@1603
|
404 if Substring.size s > 1 andalso Char.isSpace (Substring.sub (s, Substring.size s - 2)) then
|
adam@1603
|
405 Substring.trimr 2 s
|
adam@1603
|
406 else
|
adam@1603
|
407 Substring.trimr 1 s
|
adam@1603
|
408 else
|
adam@1603
|
409 s))
|
adam@1603
|
410 end
|
adam@1603
|
411 end
|
adam@1331
|
412
|
adam@1780
|
413 val lastUrp = ref ""
|
adam@1780
|
414
|
adamc@1082
|
415 fun parseUrp' accLibs fname =
|
adam@1780
|
416 (if !lastUrp = fname then
|
adam@1780
|
417 ()
|
adam@1780
|
418 else
|
adam@1780
|
419 ModDb.reset ();
|
adam@1780
|
420 lastUrp := fname;
|
adam@1780
|
421 if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", []))
|
adam@1780
|
422 andalso Posix.FileSys.access (fname ^ ".ur", []) then
|
adam@1780
|
423 let
|
adam@1780
|
424 val job = {prefix = "/",
|
adam@1780
|
425 database = NONE,
|
adam@1780
|
426 sources = [fname],
|
adam@1780
|
427 exe = fname ^ ".exe",
|
adam@1780
|
428 sql = NONE,
|
adam@1780
|
429 debug = Settings.getDebug (),
|
adam@1780
|
430 profile = false,
|
adam@1780
|
431 timeout = 60,
|
adam@1780
|
432 ffi = [],
|
adam@1780
|
433 link = [],
|
adam@1780
|
434 linker = NONE,
|
adam@1780
|
435 headers = [],
|
adam@1780
|
436 scripts = [],
|
adam@1780
|
437 clientToServer = [],
|
adam@1780
|
438 effectful = [],
|
adam@1780
|
439 benignEffectful = [],
|
adam@1780
|
440 clientOnly = [],
|
adam@1780
|
441 serverOnly = [],
|
adam@1780
|
442 jsFuncs = [],
|
adam@1780
|
443 rewrites = [{pkind = Settings.Any,
|
adam@1780
|
444 kind = Settings.Prefix,
|
adam@1780
|
445 from = capitalize (OS.Path.file fname) ^ "/", to = "",
|
adam@1780
|
446 hyphenate = false}],
|
adam@1780
|
447 filterUrl = [],
|
adam@1780
|
448 filterMime = [],
|
adam@1780
|
449 filterRequest = [],
|
adam@1780
|
450 filterResponse = [],
|
adam@1799
|
451 filterEnv = [],
|
adam@1780
|
452 protocol = NONE,
|
adam@1780
|
453 dbms = NONE,
|
adam@1780
|
454 sigFile = NONE,
|
adam@1780
|
455 safeGets = [],
|
adam@1780
|
456 onError = NONE,
|
adam@1780
|
457 minHeap = 0}
|
adam@1780
|
458 in
|
adam@1780
|
459 institutionalizeJob job;
|
adam@1780
|
460 {Job = job, Libs = []}
|
adam@1780
|
461 end
|
adam@1780
|
462 else
|
adam@1780
|
463 let
|
adam@1780
|
464 val pathmap = ref (!pathmap)
|
adam@1780
|
465 val bigLibs = ref []
|
adamc@767
|
466
|
adam@1780
|
467 fun pu filename =
|
adam@1780
|
468 let
|
adam@1780
|
469 val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()}
|
adam@2113
|
470 val thisPath = OS.Path.dir filename
|
adam@1338
|
471
|
adam@1780
|
472 val dir = OS.Path.dir filename
|
adam@1780
|
473 fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
|
adamc@1151
|
474
|
adam@1780
|
475 val inf = opener ()
|
adamc@1151
|
476
|
adam@1780
|
477 fun hasSpaceLine () =
|
adam@1780
|
478 case inputCommentableLine inf of
|
adam@1780
|
479 Content s => s = "debug" orelse s = "profile"
|
adam@1780
|
480 orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine ()
|
adam@1780
|
481 | EndOfFile => false
|
adam@1780
|
482 | OnlyComment => hasSpaceLine ()
|
adamc@1151
|
483
|
adam@1780
|
484 val hasBlankLine = hasSpaceLine ()
|
adamc@1151
|
485
|
adam@1780
|
486 val inf = (TextIO.closeIn inf; opener ())
|
adamc@767
|
487
|
adam@1780
|
488 fun pathify fname =
|
adam@1780
|
489 if size fname > 0 andalso String.sub (fname, 0) = #"$" then
|
adam@1780
|
490 let
|
adam@1780
|
491 val fname' = Substring.extract (fname, 1, NONE)
|
adam@1780
|
492 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
|
adam@1780
|
493 in
|
adam@1780
|
494 case M.find (!pathmap, Substring.string befor) of
|
adam@1780
|
495 NONE => fname
|
adam@1780
|
496 | SOME rep => rep ^ Substring.string after
|
adam@1780
|
497 end
|
adam@1780
|
498 else
|
adam@1780
|
499 fname
|
adam@1296
|
500
|
adam@1780
|
501 fun relify fname =
|
adam@1780
|
502 let
|
adam@1780
|
503 val fname = pathify fname
|
adam@1780
|
504 in
|
adam@1780
|
505 OS.Path.concat (dir, fname)
|
adam@1780
|
506 handle OS.Path.Path => fname
|
adam@1780
|
507 end
|
adamc@767
|
508
|
adam@1780
|
509 fun libify path =
|
adam@1780
|
510 (if Posix.FileSys.access (path ^ ".urp", []) then
|
adam@1780
|
511 path
|
adam@1780
|
512 else
|
adam@1780
|
513 path ^ "/lib")
|
adam@1780
|
514 handle SysErr => path
|
adam@1780
|
515
|
adam@1780
|
516 fun libify' path =
|
adam@1780
|
517 (if Posix.FileSys.access (relify path ^ ".urp", []) then
|
adam@1780
|
518 path
|
adam@1780
|
519 else
|
adam@1780
|
520 path ^ "/lib")
|
adam@1780
|
521 handle SysErr => path
|
adam@1780
|
522
|
adam@1780
|
523 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
|
adam@1780
|
524
|
adam@1780
|
525 fun relifyA fname =
|
adam@1780
|
526 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
|
adam@1780
|
527
|
adam@1780
|
528 fun readSources acc =
|
adam@1780
|
529 case inputCommentableLine inf of
|
adam@1780
|
530 Content line =>
|
adam@1780
|
531 let
|
adam@1780
|
532 val acc = if CharVector.all Char.isSpace line then
|
adam@1780
|
533 acc
|
adam@1780
|
534 else
|
adam@1780
|
535 let
|
adam@1780
|
536 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
|
adam@1780
|
537 (String.explode line))
|
adam@1780
|
538 val fname = relifyA fname
|
adam@1780
|
539 in
|
adam@1780
|
540 fname :: acc
|
adam@1780
|
541 end
|
adam@1780
|
542 in
|
adam@1780
|
543 readSources acc
|
adam@1780
|
544 end
|
adam@1780
|
545 | OnlyComment => readSources acc
|
adam@1780
|
546 | EndOfFile => rev acc
|
adam@1780
|
547
|
adam@1780
|
548 val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s)
|
adam@1780
|
549 val database = ref (Settings.getDbstring ())
|
adam@1780
|
550 val exe = ref (Settings.getExe ())
|
adam@1780
|
551 val sql = ref (Settings.getSql ())
|
adam@1780
|
552 val debug = ref (Settings.getDebug ())
|
adam@1780
|
553 val profile = ref false
|
adam@1780
|
554 val timeout = ref NONE
|
adam@1780
|
555 val ffi = ref []
|
adam@1780
|
556 val link = ref []
|
adam@1780
|
557 val linker = ref NONE
|
adam@1780
|
558 val headers = ref []
|
adam@1780
|
559 val scripts = ref []
|
adam@1780
|
560 val clientToServer = ref []
|
adam@1780
|
561 val effectful = ref []
|
adam@1780
|
562 val benignEffectful = ref []
|
adam@1780
|
563 val clientOnly = ref []
|
adam@1780
|
564 val serverOnly = ref []
|
adam@1780
|
565 val jsFuncs = ref []
|
adam@1780
|
566 val rewrites = ref []
|
adam@1780
|
567 val url = ref []
|
adam@1780
|
568 val mime = ref []
|
adam@1780
|
569 val request = ref []
|
adam@1780
|
570 val response = ref []
|
adam@1799
|
571 val env = ref []
|
adam@1780
|
572 val libs = ref []
|
adam@1780
|
573 val protocol = ref NONE
|
adam@1780
|
574 val dbms = ref NONE
|
adam@1780
|
575 val sigFile = ref (Settings.getSigFile ())
|
adam@1780
|
576 val safeGets = ref []
|
adam@1780
|
577 val onError = ref NONE
|
adam@1780
|
578 val minHeap = ref 0
|
adam@1780
|
579
|
adam@1780
|
580 fun finish sources =
|
adam@1780
|
581 let
|
adam@1780
|
582 val job = {
|
adam@1780
|
583 prefix = Option.getOpt (!prefix, "/"),
|
adam@1780
|
584 database = !database,
|
adam@1780
|
585 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
|
adam@1780
|
586 ext = SOME "exe"}),
|
adam@1780
|
587 sql = !sql,
|
adam@1780
|
588 debug = !debug,
|
adam@1780
|
589 profile = !profile,
|
adam@1780
|
590 timeout = Option.getOpt (!timeout, 60),
|
adam@1780
|
591 ffi = rev (!ffi),
|
adam@1780
|
592 link = rev (!link),
|
adam@1780
|
593 linker = !linker,
|
adam@1780
|
594 headers = rev (!headers),
|
adam@1780
|
595 scripts = rev (!scripts),
|
adam@1780
|
596 clientToServer = rev (!clientToServer),
|
adam@1780
|
597 effectful = rev (!effectful),
|
adam@1780
|
598 benignEffectful = rev (!benignEffectful),
|
adam@1780
|
599 clientOnly = rev (!clientOnly),
|
adam@1780
|
600 serverOnly = rev (!serverOnly),
|
adam@1780
|
601 jsFuncs = rev (!jsFuncs),
|
adam@1780
|
602 rewrites = rev (!rewrites),
|
adam@1780
|
603 filterUrl = rev (!url),
|
adam@1780
|
604 filterMime = rev (!mime),
|
adam@1780
|
605 filterRequest = rev (!request),
|
adam@1780
|
606 filterResponse = rev (!response),
|
adam@1799
|
607 filterEnv = rev (!env),
|
adam@1780
|
608 sources = sources,
|
adam@1780
|
609 protocol = !protocol,
|
adam@1780
|
610 dbms = !dbms,
|
adam@1780
|
611 sigFile = !sigFile,
|
adam@1780
|
612 safeGets = rev (!safeGets),
|
adam@1780
|
613 onError = !onError,
|
adam@1780
|
614 minHeap = !minHeap
|
adam@1780
|
615 }
|
adam@1780
|
616
|
adam@1780
|
617 fun mergeO f (old, new) =
|
adam@1780
|
618 case (old, new) of
|
adam@1780
|
619 (NONE, _) => new
|
adam@1780
|
620 | (_, NONE) => old
|
adam@1780
|
621 | (SOME v1, SOME v2) => SOME (f (v1, v2))
|
adam@1780
|
622
|
adam@1780
|
623 fun same desc = mergeO (fn (x : string, y) =>
|
adam@1780
|
624 (if x = y then
|
adam@1780
|
625 ()
|
adam@1780
|
626 else
|
adam@1780
|
627 ErrorMsg.error ("Multiple "
|
adam@1780
|
628 ^ desc ^ " values that don't agree");
|
adam@1780
|
629 x))
|
adam@1780
|
630
|
adam@1780
|
631 fun merge (old : job, new : job) = {
|
adam@1780
|
632 prefix = case #prefix old of
|
adam@1780
|
633 "/" => #prefix new
|
adam@1780
|
634 | pold => case #prefix new of
|
adam@1780
|
635 "/" => pold
|
adam@1780
|
636 | pnew => (if pold = pnew then
|
adam@1780
|
637 ()
|
adam@1780
|
638 else
|
adam@1780
|
639 ErrorMsg.error ("Multiple prefix values that don't agree: "
|
adam@1780
|
640 ^ pold ^ ", " ^ pnew);
|
adam@1780
|
641 pold),
|
adam@1780
|
642 database = mergeO (fn (old, _) => old) (#database old, #database new),
|
adam@1780
|
643 exe = #exe old,
|
adam@1780
|
644 sql = #sql old,
|
adam@1780
|
645 debug = #debug old orelse #debug new,
|
adam@1780
|
646 profile = #profile old orelse #profile new,
|
adam@1780
|
647 timeout = #timeout old,
|
adam@1780
|
648 ffi = #ffi old @ #ffi new,
|
adam@1780
|
649 link = #link old @ #link new,
|
adam@1780
|
650 linker = mergeO (fn (_, new) => new) (#linker old, #linker new),
|
adam@1780
|
651 headers = #headers old @ #headers new,
|
adam@1780
|
652 scripts = #scripts old @ #scripts new,
|
adam@1780
|
653 clientToServer = #clientToServer old @ #clientToServer new,
|
adam@1780
|
654 effectful = #effectful old @ #effectful new,
|
adam@1780
|
655 benignEffectful = #benignEffectful old @ #benignEffectful new,
|
adam@1780
|
656 clientOnly = #clientOnly old @ #clientOnly new,
|
adam@1780
|
657 serverOnly = #serverOnly old @ #serverOnly new,
|
adam@1780
|
658 jsFuncs = #jsFuncs old @ #jsFuncs new,
|
adam@1780
|
659 rewrites = #rewrites old @ #rewrites new,
|
adam@1780
|
660 filterUrl = #filterUrl old @ #filterUrl new,
|
adam@1780
|
661 filterMime = #filterMime old @ #filterMime new,
|
adam@1780
|
662 filterRequest = #filterRequest old @ #filterRequest new,
|
adam@1780
|
663 filterResponse = #filterResponse old @ #filterResponse new,
|
adam@1799
|
664 filterEnv = #filterEnv old @ #filterEnv new,
|
adam@1780
|
665 sources = #sources new
|
adam@1780
|
666 @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
|
adam@1780
|
667 (#sources old),
|
adam@1780
|
668 protocol = mergeO #2 (#protocol old, #protocol new),
|
adam@1780
|
669 dbms = mergeO #2 (#dbms old, #dbms new),
|
adam@1780
|
670 sigFile = mergeO #2 (#sigFile old, #sigFile new),
|
adam@1780
|
671 safeGets = #safeGets old @ #safeGets new,
|
adam@1780
|
672 onError = mergeO #2 (#onError old, #onError new),
|
adam@1780
|
673 minHeap = Int.max (#minHeap old, #minHeap new)
|
adam@1780
|
674 }
|
adam@1780
|
675 in
|
adam@1780
|
676 if accLibs then
|
adam@1780
|
677 foldr (fn (job', job) => merge (job, job')) job (!libs)
|
adam@1780
|
678 else
|
adam@1780
|
679 job
|
adam@1780
|
680 end
|
adam@1780
|
681
|
adam@1780
|
682 fun parsePkind s =
|
adam@1780
|
683 case s of
|
adam@1780
|
684 "all" => Settings.Any
|
adam@1780
|
685 | "url" => Settings.Url
|
adam@1780
|
686 | "table" => Settings.Table
|
adam@1780
|
687 | "sequence" => Settings.Sequence
|
adam@1780
|
688 | "view" => Settings.View
|
adam@1780
|
689 | "relation" => Settings.Relation
|
adam@1780
|
690 | "cookie" => Settings.Cookie
|
adam@1780
|
691 | "style" => Settings.Style
|
adam@1780
|
692 | _ => (ErrorMsg.error "Bad path kind spec";
|
adam@1780
|
693 Settings.Any)
|
adam@1780
|
694
|
adam@2096
|
695 fun parsePattern s =
|
adam@2096
|
696 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
|
adam@1780
|
697 (Settings.Prefix, String.substring (s, 0, size s - 1))
|
adam@1296
|
698 else
|
adam@1780
|
699 (Settings.Exact, s)
|
adamc@767
|
700
|
adam@1780
|
701 fun parseFkind s =
|
adam@1780
|
702 case s of
|
adam@1780
|
703 "url" => url
|
adam@1780
|
704 | "mime" => mime
|
adam@1780
|
705 | "requestHeader" => request
|
adam@1780
|
706 | "responseHeader" => response
|
adam@1799
|
707 | "env" => env
|
adam@1780
|
708 | _ => (ErrorMsg.error "Bad filter kind";
|
adam@1780
|
709 url)
|
adam@1780
|
710
|
adam@1780
|
711 fun read () =
|
adam@1780
|
712 case inputCommentableLine inf of
|
adam@1780
|
713 EndOfFile => finish []
|
adam@1780
|
714 | OnlyComment => read ()
|
adam@1780
|
715 | Content "" => finish (readSources [])
|
adam@1780
|
716 | Content line =>
|
adam@1780
|
717 let
|
adam@1780
|
718 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
|
adam@1780
|
719 val cmd = Substring.string (trim cmd)
|
adam@1780
|
720 val arg = Substring.string (trim arg)
|
adamc@794
|
721
|
adam@1780
|
722 fun ffiS () =
|
adam@1780
|
723 case String.fields (fn ch => ch = #".") arg of
|
adam@1780
|
724 [m, x] => (m, x)
|
adam@1780
|
725 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
|
adam@1780
|
726 ("", ""))
|
adamc@794
|
727
|
adam@1780
|
728 fun ffiM () =
|
adam@1780
|
729 case String.fields (fn ch => ch = #"=") arg of
|
adam@1780
|
730 [f, s] =>
|
adam@1780
|
731 let
|
adam@1780
|
732 val f = trimS f
|
adam@1780
|
733 val s = trimS s
|
adam@1780
|
734 in
|
adam@1780
|
735 case String.fields (fn ch => ch = #".") f of
|
adam@1780
|
736 [m, x] => ((m, x), s)
|
adam@1780
|
737 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
|
adam@1780
|
738 (("", ""), ""))
|
adam@1780
|
739 end
|
adam@1780
|
740 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
|
adam@1780
|
741 (("", ""), ""))
|
adam@1780
|
742 in
|
adam@1780
|
743 case cmd of
|
adam@1780
|
744 "prefix" => prefix := SOME arg
|
adam@1780
|
745 | "database" =>
|
adam@1780
|
746 (case !database of
|
adam@1780
|
747 NONE => database := SOME arg
|
adam@1780
|
748 | SOME _ => ())
|
adam@1780
|
749 | "dbms" =>
|
adam@1780
|
750 (case !dbms of
|
adam@1780
|
751 NONE => dbms := SOME arg
|
adam@1780
|
752 | SOME _ => ())
|
adam@1780
|
753 | "sigfile" =>
|
adam@1780
|
754 (case !sigFile of
|
adam@1780
|
755 NONE => sigFile := SOME arg
|
adam@1780
|
756 | SOME _ => ())
|
adam@1780
|
757 | "exe" =>
|
adam@1780
|
758 (case !exe of
|
adam@1780
|
759 NONE => exe := SOME (relify arg)
|
adam@1780
|
760 | SOME _ => ())
|
adam@1780
|
761 | "sql" =>
|
adam@1780
|
762 (case !sql of
|
adam@1780
|
763 NONE => sql := SOME (relify arg)
|
adam@1780
|
764 | SOME _ => ())
|
adam@1780
|
765 | "debug" => debug := true
|
adam@1780
|
766 | "profile" => profile := true
|
adam@1780
|
767 | "timeout" =>
|
adam@1780
|
768 (case !timeout of
|
adam@1780
|
769 NONE => ()
|
adam@1780
|
770 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
|
adam@1780
|
771 timeout := SOME (valOf (Int.fromString arg)))
|
adam@1780
|
772 | "ffi" => ffi := relify arg :: !ffi
|
adam@1780
|
773 | "link" => let
|
adam@1780
|
774 val arg = if size arg >= 1
|
adam@1780
|
775 andalso String.sub (arg, 0) = #"-" then
|
adam@1780
|
776 arg
|
adam@1780
|
777 else
|
adam@1780
|
778 relifyA arg
|
adam@1780
|
779 in
|
adam@1780
|
780 link := arg :: !link
|
adam@1780
|
781 end
|
adam@1780
|
782 | "linker" => linker := SOME arg
|
adam@1780
|
783 | "include" => headers := relifyA arg :: !headers
|
adam@1780
|
784 | "script" => scripts := arg :: !scripts
|
adam@1780
|
785 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
|
adam@1780
|
786 | "safeGet" => safeGets := arg :: !safeGets
|
adam@1780
|
787 | "effectful" => effectful := ffiS () :: !effectful
|
adam@1780
|
788 | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
|
adam@1780
|
789 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
|
adam@1780
|
790 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
|
adam@1780
|
791 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
|
adam@1780
|
792 | "rewrite" =>
|
adam@1780
|
793 let
|
adam@1780
|
794 fun doit (pkind, from, to, hyph) =
|
adam@1780
|
795 let
|
adam@1780
|
796 val pkind = parsePkind pkind
|
adam@2096
|
797 val (kind, from) = parsePattern from
|
adam@1780
|
798 in
|
adam@1780
|
799 rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites
|
adam@1780
|
800 end
|
adam@1780
|
801 in
|
adam@1780
|
802 case String.tokens Char.isSpace arg of
|
adam@1780
|
803 [pkind, from, to, "[-]"] => doit (pkind, from, to, true)
|
adam@1780
|
804 | [pkind, from, "[-]"] => doit (pkind, from, "", true)
|
adam@1780
|
805 | [pkind, from, to] => doit (pkind, from, to, false)
|
adam@1780
|
806 | [pkind, from] => doit (pkind, from, "", false)
|
adam@1780
|
807 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
|
adam@1780
|
808 end
|
adam@1780
|
809 | "allow" =>
|
adam@1780
|
810 (case String.tokens Char.isSpace arg of
|
adam@1780
|
811 [fkind, pattern] =>
|
adam@1780
|
812 let
|
adam@1780
|
813 val fkind = parseFkind fkind
|
adam@1780
|
814 val (kind, pattern) = parsePattern pattern
|
adam@1780
|
815 in
|
adam@1780
|
816 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
|
adam@1780
|
817 end
|
adam@1780
|
818 | _ => ErrorMsg.error "Bad 'allow' syntax")
|
adam@1780
|
819 | "deny" =>
|
adam@1780
|
820 (case String.tokens Char.isSpace arg of
|
adam@1780
|
821 [fkind, pattern] =>
|
adam@1780
|
822 let
|
adam@1780
|
823 val fkind = parseFkind fkind
|
adam@1780
|
824 val (kind, pattern) = parsePattern pattern
|
adam@1780
|
825 in
|
adam@1780
|
826 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
|
adam@1780
|
827 end
|
adam@1780
|
828 | _ => ErrorMsg.error "Bad 'deny' syntax")
|
adam@1780
|
829 | "library" => if accLibs then
|
adam@1780
|
830 libs := pu (libify (relify arg)) :: !libs
|
adam@1780
|
831 else
|
adam@1780
|
832 bigLibs := libify' arg :: !bigLibs
|
adam@1780
|
833 | "path" =>
|
adam@1780
|
834 (case String.fields (fn ch => ch = #"=") arg of
|
adam@1780
|
835 [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir}))
|
adam@1780
|
836 handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument")
|
adam@1780
|
837 | _ => ErrorMsg.error "path argument not of the form name=value'")
|
adam@1780
|
838 | "onError" =>
|
adam@1780
|
839 (case String.fields (fn ch => ch = #".") arg of
|
adam@1780
|
840 m1 :: (fs as _ :: _) =>
|
adam@1780
|
841 onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
|
adam@1780
|
842 | _ => ErrorMsg.error "invalid 'onError' argument")
|
adam@1780
|
843 | "limit" =>
|
adam@1780
|
844 (case String.fields Char.isSpace arg of
|
adam@1780
|
845 [class, num] =>
|
adam@1780
|
846 (case Int.fromString num of
|
adam@1780
|
847 NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
|
adam@1780
|
848 | SOME n =>
|
adam@1780
|
849 if n < 0 then
|
adam@1780
|
850 ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
|
adam@1780
|
851 else
|
adam@1780
|
852 Settings.addLimit (class, n))
|
adam@1780
|
853 | _ => ErrorMsg.error "invalid 'limit' arguments")
|
adam@1780
|
854 | "minHeap" =>
|
adam@1780
|
855 (case Int.fromString arg of
|
adam@1780
|
856 NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'")
|
adam@1780
|
857 | SOME n => minHeap := n)
|
vshabanoff@1815
|
858 | "coreInline" =>
|
vshabanoff@1815
|
859 (case Int.fromString arg of
|
vshabanoff@1815
|
860 NONE => ErrorMsg.error ("invalid core inline level '" ^ arg ^ "'")
|
vshabanoff@1815
|
861 | SOME n => Settings.setCoreInline n)
|
vshabanoff@1815
|
862 | "monoInline" =>
|
vshabanoff@1815
|
863 (case Int.fromString arg of
|
vshabanoff@1815
|
864 NONE => ErrorMsg.error ("invalid mono inline level '" ^ arg ^ "'")
|
vshabanoff@1815
|
865 | SOME n => Settings.setMonoInline n)
|
adam@1780
|
866 | "alwaysInline" => Settings.addAlwaysInline arg
|
adam@1966
|
867 | "neverInline" => Settings.addNeverInline arg
|
adam@1780
|
868 | "noXsrfProtection" => Settings.addNoXsrfProtection arg
|
adam@1780
|
869 | "timeFormat" => Settings.setTimeFormat arg
|
adam@1953
|
870 | "noMangleSql" => Settings.setMangleSql false
|
adam@1956
|
871 | "html5" => Settings.setIsHtml5 true
|
adam@2010
|
872 | "lessSafeFfi" => Settings.setLessSafeFfi true
|
adamc@794
|
873
|
adam@2046
|
874 | "file" =>
|
adam@2046
|
875 (case String.fields Char.isSpace arg of
|
adam@2046
|
876 [uri, fname] => (Settings.setFilePath thisPath;
|
adam@2046
|
877 Settings.addFile {Uri = uri,
|
julian@2139
|
878 LoadFromFilename = fname};
|
julian@2139
|
879 url := {action = Settings.Allow, kind = Settings.Exact, pattern = uri} :: !url)
|
adam@2046
|
880 | _ => ErrorMsg.error "Bad 'file' arguments")
|
adam@2046
|
881
|
adam@1780
|
882 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
|
adam@1780
|
883 read ()
|
adam@1780
|
884 end
|
adamc@794
|
885
|
adam@1780
|
886 val job = if hasBlankLine then
|
adam@1780
|
887 read ()
|
adam@1780
|
888 else
|
adam@1780
|
889 finish (readSources [])
|
adam@1780
|
890 in
|
adam@1780
|
891 TextIO.closeIn inf;
|
adam@1780
|
892 institutionalizeJob job;
|
adam@1780
|
893 job
|
adam@1780
|
894 end
|
adam@1780
|
895 in
|
adam@1780
|
896 {Job = pu fname, Libs = !bigLibs}
|
adam@1780
|
897 end)
|
adamc@767
|
898
|
adamc@1082
|
899 fun p_job' {Job = j, Libs = _ : string list} = p_job j
|
adamc@1082
|
900
|
adamc@270
|
901 val parseUrp = {
|
adamc@1083
|
902 func = #Job o parseUrp' true,
|
adamc@270
|
903 print = p_job
|
adamc@270
|
904 }
|
adamc@270
|
905
|
adamc@1082
|
906 val parseUrp' = {
|
adamc@1083
|
907 func = parseUrp' false,
|
adamc@1082
|
908 print = p_job'
|
adamc@1082
|
909 }
|
adamc@1082
|
910
|
adamc@270
|
911 val toParseJob = transform parseUrp "parseJob"
|
adamc@1082
|
912 val toParseJob' = transform parseUrp' "parseJob'"
|
adamc@1082
|
913
|
adamc@1082
|
914 fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
|
adamc@1082
|
915 func = fn input => case #func tr1 input of
|
adamc@1082
|
916 NONE => NONE
|
adamc@1082
|
917 | SOME v => #func tr2 v,
|
adamc@1082
|
918 print = #print tr2,
|
adamc@1082
|
919 time = fn (input, pmap) => let
|
adamc@1082
|
920 val (ro, pmap) = #time tr1 (input, pmap)
|
adamc@1082
|
921 in
|
adamc@1082
|
922 case ro of
|
adamc@1082
|
923 NONE => (NONE, pmap)
|
adamc@1082
|
924 | SOME v => #time tr2 (v, pmap)
|
adamc@1082
|
925 end
|
adamc@1082
|
926 }
|
adamc@270
|
927
|
adamc@1090
|
928 structure SM = BinaryMapFn(struct
|
adamc@1090
|
929 type ord_key = string
|
adamc@1090
|
930 val compare = String.compare
|
adamc@1090
|
931 end)
|
adamc@1090
|
932
|
adamc@1090
|
933 val moduleRoots = ref ([] : (string * string) list)
|
adam@1868
|
934 fun addModuleRoot (k, v) = moduleRoots :=
|
adam@1868
|
935 (OS.Path.mkAbsolute {path = k,
|
adam@1868
|
936 relativeTo = OS.FileSys.getDir ()},
|
adam@1868
|
937 v) :: !moduleRoots
|
adamc@1090
|
938
|
adam@1743
|
939 structure SK = struct
|
adam@1743
|
940 type ord_key = string
|
adam@1743
|
941 val compare = String.compare
|
adam@1743
|
942 end
|
adam@1743
|
943
|
adam@1743
|
944 structure SS = BinarySetFn(SK)
|
adam@1743
|
945 structure SM = BinaryMapFn(SK)
|
adamc@1090
|
946
|
adam@1773
|
947 exception MissingFile of string
|
adam@1773
|
948
|
adamc@201
|
949 val parse = {
|
adam@1294
|
950 func = fn {database, sources = fnames, ffi, onError, ...} : job =>
|
adamc@201
|
951 let
|
adamc@1090
|
952 val mrs = !moduleRoots
|
adamc@1090
|
953
|
adamc@834
|
954 val anyErrors = ref false
|
adamc@834
|
955 fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ())
|
adam@1343
|
956 fun nameOf fname =
|
adam@1343
|
957 let
|
adam@1343
|
958 val fname = OS.Path.file fname
|
adam@1343
|
959 val fst = if size fname = 0 then #"!" else String.sub (fname, 0)
|
adam@1343
|
960 in
|
adam@1343
|
961 if not (Char.isAlpha fst) then
|
adam@1343
|
962 ErrorMsg.error ("Filename doesn't start with letter: " ^ fname)
|
adam@1343
|
963 else if CharVector.exists (fn ch => not (Char.isAlphaNum ch) andalso ch <> #"_") fname then
|
adam@1343
|
964 ErrorMsg.error ("Filename contains a character that isn't alphanumeric or underscore: " ^ fname)
|
adam@1343
|
965 else
|
adam@1343
|
966 ();
|
adam@1343
|
967 capitalize fname
|
adam@1343
|
968 end
|
adamc@109
|
969
|
adamc@764
|
970 fun parseFfi fname =
|
adamc@764
|
971 let
|
adamc@764
|
972 val mname = nameOf fname
|
adamc@764
|
973 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@764
|
974
|
adamc@764
|
975 val loc = {file = urs,
|
adamc@764
|
976 first = ErrorMsg.dummyPos,
|
adamc@764
|
977 last = ErrorMsg.dummyPos}
|
adamc@764
|
978
|
adamc@764
|
979 val sgn = (Source.SgnConst (#func parseUrs urs), loc)
|
adamc@764
|
980 in
|
adamc@834
|
981 checkErrors ();
|
adam@1733
|
982 (Source.DFfiStr (mname, sgn, if !Elaborate.incremental then SOME (OS.FileSys.modTime urs) else NONE), loc)
|
adamc@764
|
983 end
|
adamc@764
|
984
|
adamc@1090
|
985 val defed = ref SS.empty
|
adamc@1092
|
986 val fulls = ref SS.empty
|
adamc@1090
|
987
|
adamc@201
|
988 fun parseOne fname =
|
adamc@201
|
989 let
|
adamc@201
|
990 val mname = nameOf fname
|
adamc@244
|
991 val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"}
|
adamc@244
|
992 val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
|
adamc@56
|
993
|
adam@1773
|
994 val () = if Posix.FileSys.access (ur, []) then
|
adam@1773
|
995 ()
|
adam@1773
|
996 else
|
adam@1773
|
997 raise MissingFile ur
|
adam@1773
|
998
|
adamc@201
|
999 val sgnO =
|
adamc@244
|
1000 if Posix.FileSys.access (urs, []) then
|
adamc@244
|
1001 SOME (Source.SgnConst (#func parseUrs urs),
|
adamc@244
|
1002 {file = urs,
|
adamc@201
|
1003 first = ErrorMsg.dummyPos,
|
adamc@201
|
1004 last = ErrorMsg.dummyPos})
|
adamc@834
|
1005 before checkErrors ()
|
adamc@201
|
1006 else
|
adamc@201
|
1007 NONE
|
adamc@56
|
1008
|
adamc@244
|
1009 val loc = {file = ur,
|
adamc@201
|
1010 first = ErrorMsg.dummyPos,
|
adamc@201
|
1011 last = ErrorMsg.dummyPos}
|
adamc@56
|
1012
|
adam@1738
|
1013 val urt = OS.FileSys.modTime ur
|
adam@1738
|
1014 val urst = (OS.FileSys.modTime urs) handle _ => urt
|
adam@1738
|
1015
|
adamc@244
|
1016 val ds = #func parseUr ur
|
adam@1738
|
1017 val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE,
|
adam@1868
|
1018 (Source.StrConst ds, loc), false), loc)
|
adamc@1090
|
1019
|
adamc@1126
|
1020 val fname = OS.Path.mkCanonical fname
|
adamc@1090
|
1021 val d = case List.find (fn (root, name) =>
|
adamc@1090
|
1022 String.isPrefix (root ^ "/") fname) mrs of
|
adamc@1090
|
1023 NONE => d
|
adamc@1090
|
1024 | SOME (root, name) =>
|
adamc@1090
|
1025 let
|
adamc@1090
|
1026 val fname = String.extract (fname, size root + 1, NONE)
|
adamc@1090
|
1027 val pieces = name :: String.tokens (fn ch => ch = #"/") fname
|
adamc@1090
|
1028 val pieces = List.filter (fn s => size s > 0
|
adamc@1090
|
1029 andalso Char.isAlpha (String.sub (s, 0)))
|
adamc@1090
|
1030 pieces
|
adamc@1090
|
1031 val pieces = map capitalize pieces
|
adamc@1092
|
1032 val full = String.concatWith "." pieces
|
adamc@1090
|
1033
|
adam@1868
|
1034 fun makeD first prefix pieces =
|
adamc@1090
|
1035 case pieces of
|
adamc@1090
|
1036 [] => (ErrorMsg.error "Empty module path";
|
adamc@1090
|
1037 (Source.DStyle "Boo", loc))
|
adamc@1090
|
1038 | [_] => d
|
adamc@1090
|
1039 | piece :: pieces =>
|
adamc@1090
|
1040 let
|
adamc@1146
|
1041 val this = case prefix of
|
adamc@1146
|
1042 "" => piece
|
adamc@1146
|
1043 | _ => prefix ^ "." ^ piece
|
adamc@1090
|
1044 val old = SS.member (!defed, this)
|
adamc@1146
|
1045
|
adamc@1146
|
1046 fun notThere (ch, s) =
|
adamc@1146
|
1047 Substring.isEmpty (#2 (Substring.splitl
|
adamc@1146
|
1048 (fn ch' => ch' <> ch) s))
|
adamc@1146
|
1049
|
adamc@1146
|
1050 fun simOpen () =
|
adamc@1146
|
1051 SS.foldl (fn (full, ds) =>
|
adamc@1146
|
1052 if String.isPrefix (this ^ ".") full
|
adamc@1146
|
1053 andalso notThere (#".",
|
adamc@1146
|
1054 Substring.extract (full,
|
adamc@1146
|
1055 size
|
adamc@1146
|
1056 this + 1,
|
adamc@1146
|
1057 NONE)) then
|
adamc@1146
|
1058 let
|
adamc@1146
|
1059 val parts = String.tokens
|
adamc@1146
|
1060 (fn ch => ch = #".") full
|
adamc@1146
|
1061
|
adamc@1146
|
1062 val part = List.last parts
|
adamc@1146
|
1063
|
adamc@1146
|
1064 val imp = if length parts >= 2 then
|
adamc@1146
|
1065 (Source.StrProj
|
adamc@1146
|
1066 ((Source.StrVar
|
adamc@1146
|
1067 (List.nth (parts,
|
adamc@1146
|
1068 length
|
adamc@1146
|
1069 parts
|
adamc@1146
|
1070 - 2)),
|
adamc@1146
|
1071 loc),
|
adamc@1146
|
1072 part), loc)
|
adamc@1146
|
1073 else
|
adamc@1146
|
1074 (Source.StrVar part, loc)
|
adamc@1146
|
1075 in
|
adam@1868
|
1076 (Source.DStr (part, NONE, NONE, imp, false),
|
adamc@1146
|
1077 loc) :: ds
|
adamc@1146
|
1078 end
|
adamc@1146
|
1079 else
|
adamc@1146
|
1080 ds) [] (!fulls)
|
adamc@1090
|
1081 in
|
adamc@1090
|
1082 defed := SS.add (!defed, this);
|
adam@1732
|
1083 (Source.DStr (piece, NONE, NONE,
|
adamc@1090
|
1084 (Source.StrConst (if old then
|
adamc@1146
|
1085 simOpen ()
|
adam@1868
|
1086 @ [makeD false this pieces]
|
adamc@1090
|
1087 else
|
adam@1868
|
1088 [makeD false this pieces]),
|
adam@1868
|
1089 loc), first andalso old),
|
adamc@1090
|
1090 loc)
|
adamc@1090
|
1091 end
|
adamc@1090
|
1092 in
|
adamc@1092
|
1093 if SS.member (!fulls, full) then
|
adamc@1092
|
1094 ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.")
|
adamc@1092
|
1095 else
|
adamc@1092
|
1096 ();
|
ziv@2202
|
1097
|
adam@1868
|
1098 makeD true "" pieces
|
adamc@1146
|
1099 before ignore (foldl (fn (new, path) =>
|
adamc@1146
|
1100 let
|
adamc@1146
|
1101 val new' = case path of
|
adamc@1146
|
1102 "" => new
|
adamc@1146
|
1103 | _ => path ^ "." ^ new
|
adamc@1146
|
1104 in
|
adamc@1146
|
1105 fulls := SS.add (!fulls, new');
|
adamc@1146
|
1106 new'
|
adamc@1146
|
1107 end) "" pieces)
|
adamc@1090
|
1108 end
|
adamc@201
|
1109 in
|
adamc@834
|
1110 checkErrors ();
|
adamc@1090
|
1111 d
|
adam@1773
|
1112 end handle MissingFile fname => (ErrorMsg.error ("Missing source file: " ^ fname);
|
adam@1773
|
1113 (Source.DSequence "", ErrorMsg.dummySpan))
|
adamc@56
|
1114
|
adamc@764
|
1115 val dsFfi = map parseFfi ffi
|
adamc@201
|
1116 val ds = map parseOne fnames
|
adamc@1090
|
1117 val loc = ErrorMsg.dummySpan
|
adamc@201
|
1118 in
|
adamc@834
|
1119 if !anyErrors then
|
adamc@834
|
1120 ErrorMsg.error "Parse failure"
|
adamc@834
|
1121 else
|
adamc@834
|
1122 ();
|
adamc@834
|
1123
|
adamc@201
|
1124 let
|
adamc@1126
|
1125 val final = List.last fnames
|
adamc@1126
|
1126 val final = case List.find (fn (root, name) =>
|
adamc@1126
|
1127 String.isPrefix (root ^ "/") final) mrs of
|
adamc@1126
|
1128 NONE => (Source.StrVar (nameOf final), loc)
|
adamc@1126
|
1129 | SOME (root, name) =>
|
adamc@1126
|
1130 let
|
adamc@1126
|
1131 val m = (Source.StrVar name, loc)
|
adamc@1126
|
1132 val final = String.extract (final, size root + 1, NONE)
|
adamc@1264
|
1133 val fields = String.fields (fn ch => ch = #"/") final
|
adamc@1264
|
1134 val fields = List.filter (fn s => size s = 0
|
adamc@1264
|
1135 orelse not (Char.isDigit (String.sub (s, 0))))
|
adamc@1264
|
1136 fields
|
adamc@1126
|
1137 in
|
adamc@1126
|
1138 foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc))
|
adamc@1264
|
1139 m fields
|
adamc@1126
|
1140 end
|
adamc@271
|
1141
|
adamc@764
|
1142 val ds = dsFfi @ ds
|
adamc@1126
|
1143 @ [(Source.DExport final, loc)]
|
adamc@1090
|
1144
|
adamc@1090
|
1145 val ds = case database of
|
adamc@1090
|
1146 NONE => ds
|
adamc@1090
|
1147 | SOME s => (Source.DDatabase s, loc) :: ds
|
adam@1294
|
1148
|
adam@1294
|
1149 val ds = case onError of
|
adam@1294
|
1150 NONE => ds
|
adam@1294
|
1151 | SOME v => ds @ [(Source.DOnError v, loc)]
|
adam@1868
|
1152
|
adam@1868
|
1153 fun dummy fname = {file = Settings.libFile fname,
|
adam@1868
|
1154 first = ErrorMsg.dummyPos,
|
adam@1868
|
1155 last = ErrorMsg.dummyPos}
|
adam@1868
|
1156
|
adam@1868
|
1157 val used = SM.insert (SM.empty, "Basis", dummy "basis.urs")
|
adam@1868
|
1158 val used = SM.insert (used, "Top", dummy "top.urs")
|
adamc@201
|
1159 in
|
adam@1738
|
1160 ignore (List.foldl (fn (d, used) =>
|
adam@1738
|
1161 case #1 d of
|
adam@1868
|
1162 Source.DStr (x, _, _, _, false) =>
|
adam@1743
|
1163 (case SM.find (used, x) of
|
adam@1743
|
1164 SOME loc =>
|
adam@1743
|
1165 (ErrorMsg.error ("Duplicate top-level module name " ^ x);
|
adam@1743
|
1166 Print.prefaces "Files" [("Previous", Print.PD.string (ErrorMsg.spanToString loc)),
|
adam@1743
|
1167 ("Current", Print.PD.string (ErrorMsg.spanToString (#2 d)))];
|
adam@1743
|
1168 used)
|
adam@1743
|
1169 | NONE =>
|
adam@1743
|
1170 SM.insert (used, x, #2 d))
|
adam@1868
|
1171 | _ => used) used ds);
|
adamc@1090
|
1172 ds
|
adamc@201
|
1173 end handle Empty => ds
|
adamc@201
|
1174 end,
|
adamc@201
|
1175 print = SourcePrint.p_file
|
adamc@201
|
1176 }
|
adamc@56
|
1177
|
adamc@270
|
1178 val toParse = transform parse "parse" o toParseJob
|
adamc@38
|
1179
|
adamc@201
|
1180 val elaborate = {
|
adamc@201
|
1181 func = fn file => let
|
ezyang@1739
|
1182 val basisF = Settings.libFile "basis.urs"
|
ezyang@1739
|
1183 val topF = Settings.libFile "top.urs"
|
ezyang@1739
|
1184 val topF' = Settings.libFile "top.ur"
|
adam@1732
|
1185
|
adam@1732
|
1186 val basis = #func parseUrs basisF
|
adam@1732
|
1187 val topSgn = #func parseUrs topF
|
adam@1732
|
1188 val topStr = #func parseUr topF'
|
adam@1732
|
1189
|
adam@1732
|
1190 val tm1 = OS.FileSys.modTime topF
|
adam@1732
|
1191 val tm2 = OS.FileSys.modTime topF'
|
adamc@201
|
1192 in
|
adam@1732
|
1193 Elaborate.elabFile basis (OS.FileSys.modTime basisF)
|
adam@1732
|
1194 topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1)
|
adam@1732
|
1195 ElabEnv.empty file
|
adamc@201
|
1196 end,
|
adamc@201
|
1197 print = ElabPrint.p_file ElabEnv.empty
|
adamc@201
|
1198 }
|
adamc@5
|
1199
|
adamc@270
|
1200 val toElaborate = transform elaborate "elaborate" o toParse
|
adamc@201
|
1201
|
adamc@448
|
1202 val unnest = {
|
adamc@448
|
1203 func = Unnest.unnest,
|
adamc@448
|
1204 print = ElabPrint.p_file ElabEnv.empty
|
adamc@448
|
1205 }
|
adamc@448
|
1206
|
adamc@448
|
1207 val toUnnest = transform unnest "unnest" o toElaborate
|
adamc@448
|
1208
|
adamc@313
|
1209 val termination = {
|
adamc@313
|
1210 func = (fn file => (Termination.check file; file)),
|
adamc@313
|
1211 print = ElabPrint.p_file ElabEnv.empty
|
adamc@313
|
1212 }
|
adamc@313
|
1213
|
adamc@448
|
1214 val toTermination = transform termination "termination" o toUnnest
|
adamc@313
|
1215
|
adamc@201
|
1216 val explify = {
|
adamc@201
|
1217 func = Explify.explify,
|
adamc@201
|
1218 print = ExplPrint.p_file ExplEnv.empty
|
adamc@201
|
1219 }
|
adamc@201
|
1220
|
adamc@625
|
1221 val toExplify = transform explify "explify" o toUnnest
|
adamc@201
|
1222
|
adamc@201
|
1223 val corify = {
|
adamc@201
|
1224 func = Corify.corify,
|
adamc@201
|
1225 print = CorePrint.p_file CoreEnv.empty
|
adamc@201
|
1226 }
|
adamc@201
|
1227
|
adamc@270
|
1228 val toCorify = transform corify "corify" o toExplify
|
adamc@201
|
1229
|
adamc@482
|
1230 (*val reduce_local = {
|
adamc@482
|
1231 func = ReduceLocal.reduce,
|
adamc@482
|
1232 print = CorePrint.p_file CoreEnv.empty
|
adamc@482
|
1233 }
|
adamc@482
|
1234
|
adamc@482
|
1235 val toReduce_local = transform reduce_local "reduce_local" o toCorify*)
|
adamc@482
|
1236
|
adamc@443
|
1237 val especialize = {
|
adamc@443
|
1238 func = ESpecialize.specialize,
|
adamc@443
|
1239 print = CorePrint.p_file CoreEnv.empty
|
adamc@443
|
1240 }
|
adamc@443
|
1241
|
adamc@454
|
1242 val core_untangle = {
|
adamc@454
|
1243 func = CoreUntangle.untangle,
|
adamc@454
|
1244 print = CorePrint.p_file CoreEnv.empty
|
adamc@454
|
1245 }
|
adamc@454
|
1246
|
adamc@794
|
1247 val toCore_untangle = transform core_untangle "core_untangle" o toCorify
|
adamc@454
|
1248
|
adamc@202
|
1249 val shake = {
|
adamc@202
|
1250 func = Shake.shake,
|
adamc@202
|
1251 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
1252 }
|
adamc@39
|
1253
|
adamc@454
|
1254 val toShake1 = transform shake "shake1" o toCore_untangle
|
adamc@110
|
1255
|
adam@1362
|
1256 val toEspecialize1' = transform especialize "especialize1'" o toShake1
|
adam@1362
|
1257 val toShake1' = transform shake "shake1'" o toEspecialize1'
|
adam@1362
|
1258
|
adamc@607
|
1259 val rpcify = {
|
adamc@607
|
1260 func = Rpcify.frob,
|
adamc@607
|
1261 print = CorePrint.p_file CoreEnv.empty
|
adamc@607
|
1262 }
|
adamc@607
|
1263
|
adam@1362
|
1264 val toRpcify = transform rpcify "rpcify" o toShake1'
|
adamc@607
|
1265
|
adamc@642
|
1266 val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify
|
adamc@642
|
1267 val toShake2 = transform shake "shake2" o toCore_untangle2
|
adamc@1181
|
1268
|
adamc@1186
|
1269 val toEspecialize1 = transform especialize "especialize1" o toShake2
|
adamc@1181
|
1270
|
adamc@1062
|
1271 val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1
|
adamc@1062
|
1272 val toShake3 = transform shake "shake3" o toCore_untangle3
|
adamc@642
|
1273
|
adamc@202
|
1274 val tag = {
|
adamc@202
|
1275 func = Tag.tag,
|
adamc@202
|
1276 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
1277 }
|
adamc@193
|
1278
|
adamc@1062
|
1279 val toTag = transform tag "tag" o toShake3
|
adamc@20
|
1280
|
adamc@202
|
1281 val reduce = {
|
adamc@202
|
1282 func = Reduce.reduce,
|
adamc@202
|
1283 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
1284 }
|
adamc@25
|
1285
|
adamc@692
|
1286 val toReduce = transform reduce "reduce" o toTag
|
adamc@23
|
1287
|
adamc@1186
|
1288 val toShakey = transform shake "shakey" o toReduce
|
adamc@1186
|
1289
|
adamc@1186
|
1290 val unpoly = {
|
adamc@1186
|
1291 func = Unpoly.unpoly,
|
adamc@1186
|
1292 print = CorePrint.p_file CoreEnv.empty
|
adamc@1186
|
1293 }
|
adamc@1186
|
1294
|
adamc@1186
|
1295 val toUnpoly = transform unpoly "unpoly" o toShakey
|
adamc@315
|
1296
|
adamc@202
|
1297 val specialize = {
|
adamc@202
|
1298 func = Specialize.specialize,
|
adamc@202
|
1299 print = CorePrint.p_file CoreEnv.empty
|
adamc@202
|
1300 }
|
adamc@132
|
1301
|
adamc@1186
|
1302 val toSpecialize = transform specialize "specialize" o toUnpoly
|
adamc@131
|
1303
|
adamc@1062
|
1304 val toShake4 = transform shake "shake4" o toSpecialize
|
adamc@133
|
1305
|
adamc@1062
|
1306 val toEspecialize2 = transform especialize "especialize2" o toShake4
|
adamc@1272
|
1307 val toShake4' = transform shake "shake4'" o toEspecialize2
|
adamc@1272
|
1308 val toUnpoly2 = transform unpoly "unpoly2" o toShake4'
|
adamc@1276
|
1309 val toSpecialize2 = transform specialize "specialize2" o toUnpoly2
|
adamc@1276
|
1310 val toShake4'' = transform shake "shake4'" o toSpecialize2
|
adamc@1272
|
1311 val toEspecialize3 = transform especialize "especialize3" o toShake4''
|
adamc@794
|
1312
|
adamc@1272
|
1313 val toReduce2 = transform reduce "reduce2" o toEspecialize3
|
adamc@898
|
1314
|
adamc@1062
|
1315 val toShake5 = transform shake "shake5" o toReduce2
|
adamc@794
|
1316
|
adamc@692
|
1317 val marshalcheck = {
|
adamc@692
|
1318 func = (fn file => (MarshalCheck.check file; file)),
|
adamc@692
|
1319 print = CorePrint.p_file CoreEnv.empty
|
adamc@692
|
1320 }
|
adamc@692
|
1321
|
adamc@1062
|
1322 val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5
|
adamc@692
|
1323
|
adamc@732
|
1324 val effectize = {
|
adamc@732
|
1325 func = Effective.effectize,
|
adamc@732
|
1326 print = CorePrint.p_file CoreEnv.empty
|
adamc@732
|
1327 }
|
adamc@732
|
1328
|
adamc@732
|
1329 val toEffectize = transform effectize "effectize" o toMarshalcheck
|
adamc@732
|
1330
|
adamc@1170
|
1331 val css = {
|
adamc@1170
|
1332 func = Css.summarize,
|
adamc@1170
|
1333 print = fn _ => Print.box []
|
adamc@1170
|
1334 }
|
adamc@1170
|
1335
|
adamc@1170
|
1336 val toCss = transform css "css" o toShake5
|
adamc@1170
|
1337
|
adamc@202
|
1338 val monoize = {
|
adamc@202
|
1339 func = Monoize.monoize CoreEnv.empty,
|
adamc@202
|
1340 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
1341 }
|
adamc@134
|
1342
|
adamc@732
|
1343 val toMonoize = transform monoize "monoize" o toEffectize
|
adamc@96
|
1344
|
adamc@202
|
1345 val mono_opt = {
|
adamc@910
|
1346 func = MonoOpt.optimize,
|
adamc@202
|
1347 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
1348 }
|
adamc@29
|
1349
|
adamc@270
|
1350 val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
|
adamc@5
|
1351
|
adamc@202
|
1352 val untangle = {
|
adamc@202
|
1353 func = Untangle.untangle,
|
adamc@202
|
1354 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
1355 }
|
adamc@1
|
1356
|
adamc@270
|
1357 val toUntangle = transform untangle "untangle" o toMono_opt1
|
adamc@38
|
1358
|
adamc@202
|
1359 val mono_reduce = {
|
adamc@202
|
1360 func = MonoReduce.reduce,
|
adamc@202
|
1361 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
1362 }
|
adamc@16
|
1363
|
adamc@270
|
1364 val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle
|
adamc@39
|
1365
|
adamc@202
|
1366 val mono_shake = {
|
adamc@202
|
1367 func = MonoShake.shake,
|
adamc@202
|
1368 print = MonoPrint.p_file MonoEnv.empty
|
adamc@202
|
1369 }
|
adamc@110
|
1370
|
adamc@270
|
1371 val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
|
adamc@193
|
1372
|
adamc@572
|
1373 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
|
adamc@572
|
1374
|
adamc@1200
|
1375 val iflow = {
|
adamc@1235
|
1376 func = (fn file => (if !doIflow then Iflow.check file else (); file)),
|
adamc@1200
|
1377 print = MonoPrint.p_file MonoEnv.empty
|
adamc@1200
|
1378 }
|
adamc@1200
|
1379
|
adamc@1200
|
1380 val toIflow = transform iflow "iflow" o toMono_opt2
|
adamc@1200
|
1381
|
adam@1800
|
1382 val namejs = {
|
adam@1800
|
1383 func = NameJS.rewrite,
|
adam@1800
|
1384 print = MonoPrint.p_file MonoEnv.empty
|
adam@1800
|
1385 }
|
adam@1800
|
1386
|
adam@1800
|
1387 val toNamejs = transform namejs "namejs" o toIflow
|
adam@1800
|
1388
|
adam@1800
|
1389 val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs
|
adam@1800
|
1390
|
adam@1845
|
1391 val scriptcheck = {
|
adam@1845
|
1392 func = ScriptCheck.classify,
|
adam@1845
|
1393 print = MonoPrint.p_file MonoEnv.empty
|
adam@1845
|
1394 }
|
adam@1845
|
1395
|
adam@1845
|
1396 val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle
|
adam@1845
|
1397
|
adam@2056
|
1398 val dbmodecheck = {
|
adam@2056
|
1399 func = DbModeCheck.classify,
|
adam@2056
|
1400 print = MonoPrint.p_file MonoEnv.empty
|
adam@2056
|
1401 }
|
adam@2056
|
1402
|
adam@2056
|
1403 val toDbmodecheck = transform dbmodecheck "dbmodecheck" o toScriptcheck
|
adam@2056
|
1404
|
adamc@567
|
1405 val jscomp = {
|
adamc@567
|
1406 func = JsComp.process,
|
adamc@567
|
1407 print = MonoPrint.p_file MonoEnv.empty
|
adamc@567
|
1408 }
|
adamc@567
|
1409
|
adam@2056
|
1410 val toJscomp = transform jscomp "jscomp" o toDbmodecheck
|
adamc@567
|
1411
|
adamc@910
|
1412 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
|
adamc@20
|
1413
|
adamc@506
|
1414 val fuse = {
|
adamc@506
|
1415 func = Fuse.fuse,
|
adamc@506
|
1416 print = MonoPrint.p_file MonoEnv.empty
|
adamc@506
|
1417 }
|
adamc@506
|
1418
|
adamc@572
|
1419 val toFuse = transform fuse "fuse" o toMono_opt3
|
adamc@506
|
1420
|
adamc@506
|
1421 val toUntangle2 = transform untangle "untangle2" o toFuse
|
adamc@506
|
1422
|
adamc@601
|
1423 val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2
|
adamc@601
|
1424 val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2
|
adamc@916
|
1425 val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2
|
adamc@1017
|
1426 val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4
|
adamc@1185
|
1427 val toFuse2 = transform fuse "fuse2" o toMono_reduce3
|
adamc@916
|
1428 val toUntangle3 = transform untangle "untangle3" o toFuse2
|
adamc@916
|
1429 val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3
|
adamc@506
|
1430
|
adamc@377
|
1431 val pathcheck = {
|
adamc@377
|
1432 func = (fn file => (PathCheck.check file; file)),
|
adamc@377
|
1433 print = MonoPrint.p_file MonoEnv.empty
|
adamc@377
|
1434 }
|
adamc@377
|
1435
|
adamc@916
|
1436 val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3
|
adamc@377
|
1437
|
adam@1595
|
1438 val sidecheck = {
|
adam@1595
|
1439 func = SideCheck.check,
|
adam@1595
|
1440 print = MonoPrint.p_file MonoEnv.empty
|
adam@1595
|
1441 }
|
adam@1595
|
1442
|
adam@1595
|
1443 val toSidecheck = transform sidecheck "sidecheck" o toPathcheck
|
adam@1595
|
1444
|
adam@1856
|
1445 val sigcheck = {
|
adam@1856
|
1446 func = SigCheck.check,
|
adam@1856
|
1447 print = MonoPrint.p_file MonoEnv.empty
|
adam@1856
|
1448 }
|
adam@1856
|
1449
|
adam@1856
|
1450 val toSigcheck = transform sigcheck "sigcheck" o toSidecheck
|
adam@1856
|
1451
|
ziv@2209
|
1452 val sqlcache = {
|
ziv@2213
|
1453 func = (fn file =>
|
ziv@2213
|
1454 if Settings.getSqlcache ()
|
ziv@2213
|
1455 then let val file = MonoInline.inlineFull file in Sqlcache.go file end
|
ziv@2213
|
1456 else file),
|
ziv@2202
|
1457 print = MonoPrint.p_file MonoEnv.empty
|
ziv@2202
|
1458 }
|
ziv@2202
|
1459
|
ziv@2209
|
1460 val toSqlcache = transform sqlcache "sqlcache" o toSigcheck
|
ziv@2202
|
1461
|
adamc@202
|
1462 val cjrize = {
|
adamc@202
|
1463 func = Cjrize.cjrize,
|
adamc@202
|
1464 print = CjrPrint.p_file CjrEnv.empty
|
adamc@202
|
1465 }
|
adamc@23
|
1466
|
ziv@2209
|
1467 val toCjrize = transform cjrize "cjrize" o toSqlcache
|
adamc@29
|
1468
|
adamc@282
|
1469 val prepare = {
|
adamc@282
|
1470 func = Prepare.prepare,
|
adamc@282
|
1471 print = CjrPrint.p_file CjrEnv.empty
|
adamc@282
|
1472 }
|
adamc@282
|
1473
|
adam@1845
|
1474 val toPrepare = transform prepare "prepare" o toCjrize
|
adamc@282
|
1475
|
adamc@879
|
1476 val checknest = {
|
adamc@879
|
1477 func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f,
|
adamc@879
|
1478 print = CjrPrint.p_file CjrEnv.empty
|
adamc@879
|
1479 }
|
adamc@879
|
1480
|
adamc@879
|
1481 val toChecknest = transform checknest "checknest" o toPrepare
|
adamc@879
|
1482
|
adamc@274
|
1483 val sqlify = {
|
adamc@274
|
1484 func = Cjrize.cjrize,
|
adamc@274
|
1485 print = CjrPrint.p_sql CjrEnv.empty
|
adamc@274
|
1486 }
|
adamc@274
|
1487
|
adamc@274
|
1488 val toSqlify = transform sqlify "sqlify" o toMono_opt2
|
adamc@274
|
1489
|
adam@2067
|
1490 fun escapeFilename s =
|
adam@2067
|
1491 "\""
|
adam@2067
|
1492 ^ String.translate (fn #"\"" => "\\\"" | #"\\" => "\\\\" | ch => str ch) s
|
adam@2067
|
1493 ^ "\""
|
adam@1473
|
1494
|
adam@1540
|
1495 val beforeC = ref (fn () => ())
|
adam@1540
|
1496
|
adam@1822
|
1497 structure StringSet = BinarySetFn(struct
|
adam@1822
|
1498 type ord_key = string
|
adam@1822
|
1499 val compare = String.compare
|
adam@1822
|
1500 end)
|
adam@1822
|
1501
|
adam@1725
|
1502 fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} =
|
adamc@183
|
1503 let
|
adamc@855
|
1504 val proto = Settings.currentProtocol ()
|
adamc@1095
|
1505
|
adam@1368
|
1506 val lib = if Settings.getStaticLinking () then
|
adam@1846
|
1507 " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a"
|
adam@1368
|
1508 else
|
ezyang@1739
|
1509 "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb"
|
adamc@378
|
1510
|
adam@1558
|
1511 val opt = if debug then
|
adam@1558
|
1512 ""
|
adam@1558
|
1513 else
|
adam@1558
|
1514 " -O3"
|
adam@1558
|
1515
|
grrwlf@1871
|
1516 val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value"
|
ezyang@1739
|
1517 ^ opt ^ " -I " ^ !Settings.configInclude
|
adamc@1096
|
1518 ^ " " ^ #compile proto
|
adam@1473
|
1519 ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname
|
adamc@1096
|
1520
|
grrwlf@1871
|
1521 val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " " ^ Config.pthreadLibs)
|
adam@1725
|
1522
|
adam@1846
|
1523 val ssl = if Settings.getStaticLinking () then
|
adam@1846
|
1524 Config.openssl ^ " -ldl -lz"
|
adam@1846
|
1525 else
|
adam@1846
|
1526 Config.openssl
|
adam@1846
|
1527
|
adam@1725
|
1528 val link = linker
|
andersk@1893
|
1529 ^ " " ^ escapeFilename oname ^ " " ^ lib ^ " -lm " ^ ssl ^ " " ^ libs ^ " -o " ^ escapeFilename ename
|
adamc@502
|
1530
|
adamc@502
|
1531 val (compile, link) =
|
adamc@502
|
1532 if profile then
|
adamc@502
|
1533 (compile ^ " -pg", link ^ " -pg")
|
adamc@502
|
1534 else
|
adamc@502
|
1535 (compile, link)
|
adamc@742
|
1536
|
adamc@742
|
1537 val (compile, link) =
|
adamc@742
|
1538 if debug then
|
adamc@742
|
1539 (compile ^ " -g", link ^ " -g")
|
adamc@742
|
1540 else
|
adamc@742
|
1541 (compile, link)
|
adamc@764
|
1542
|
adam@1822
|
1543 val link = #1 (foldl
|
adam@1822
|
1544 (fn (s, (link, set)) =>
|
adam@1822
|
1545 if StringSet.member (set, s) then
|
adam@1822
|
1546 (link, set)
|
adam@1822
|
1547 else
|
adam@1822
|
1548 ((link ^ " " ^ s), StringSet.add (set, s)))
|
adam@1822
|
1549 (link, StringSet.empty)
|
adam@1822
|
1550 link')
|
adam@1394
|
1551
|
adam@1394
|
1552 fun system s =
|
adam@1394
|
1553 (if debug then
|
adam@1394
|
1554 print (s ^ "\n")
|
adam@1394
|
1555 else
|
adam@1394
|
1556 ();
|
adam@1394
|
1557 OS.Process.isSuccess (OS.Process.system s))
|
adamc@183
|
1558 in
|
adam@1540
|
1559 !beforeC ();
|
adam@1394
|
1560 system compile andalso system link
|
adamc@183
|
1561 end
|
adamc@183
|
1562
|
adamc@202
|
1563 fun compile job =
|
adamc@879
|
1564 case run toChecknest job of
|
adamc@1045
|
1565 NONE => false
|
adamc@29
|
1566 | SOME file =>
|
adamc@202
|
1567 let
|
adamc@274
|
1568 val job = valOf (run (transform parseUrp "parseUrp") job)
|
adamc@102
|
1569
|
adamc@274
|
1570 val (cname, oname, cleanup) =
|
adamc@274
|
1571 if #debug job then
|
adamc@457
|
1572 ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ())
|
adamc@274
|
1573 else
|
adamc@274
|
1574 let
|
adamc@274
|
1575 val dir = OS.FileSys.tmpName ()
|
adamc@403
|
1576 val () = if OS.FileSys.access (dir, []) then
|
adamc@403
|
1577 OS.FileSys.remove dir
|
adamc@403
|
1578 else
|
adamc@403
|
1579 ()
|
adamc@457
|
1580 val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"}
|
adamc@457
|
1581 val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"}
|
adamc@274
|
1582 in
|
adamc@274
|
1583 OS.FileSys.mkDir dir;
|
adamc@274
|
1584 (cname, oname,
|
adam@1700
|
1585 fn () => (if OS.Process.isSuccess (OS.Process.system ("rm -rf " ^ dir)) then
|
adam@1700
|
1586 ()
|
adam@1700
|
1587 else
|
adam@1700
|
1588 raise Fail ("Unable to delete temporary directory " ^ dir)))
|
adamc@274
|
1589 end
|
adamc@274
|
1590 val ename = #exe job
|
adamc@202
|
1591 in
|
adamc@274
|
1592 let
|
adamc@274
|
1593 val outf = TextIO.openOut cname
|
adamc@274
|
1594 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adamc@432
|
1595
|
adamc@432
|
1596 val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
|
adamc@432
|
1597 val libs =
|
adamc@432
|
1598 if hasDb then
|
adamc@866
|
1599 #link (Settings.currentDbms ())
|
adamc@432
|
1600 else
|
adamc@432
|
1601 ""
|
adamc@274
|
1602 in
|
adamc@274
|
1603 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
|
adamc@415
|
1604 TextIO.output1 (outf, #"\n");
|
adamc@274
|
1605 TextIO.closeOut outf;
|
adamc@102
|
1606
|
adam@1381
|
1607 if ErrorMsg.anyErrors () then
|
adam@1381
|
1608 false
|
adam@1381
|
1609 else
|
adam@1381
|
1610 (case #sql job of
|
adam@1381
|
1611 NONE => ()
|
adam@1381
|
1612 | SOME sql =>
|
adam@1381
|
1613 let
|
adam@1381
|
1614 val outf = TextIO.openOut sql
|
adam@1381
|
1615 val s = TextIOPP.openOut {dst = outf, wid = 80}
|
adam@1381
|
1616 in
|
adam@1381
|
1617 Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
|
adam@1381
|
1618 TextIO.closeOut outf
|
adam@1381
|
1619 end;
|
adamc@274
|
1620
|
adam@1381
|
1621 compileC {cname = cname, oname = oname, ename = ename, libs = libs,
|
adam@1725
|
1622 profile = #profile job, debug = #debug job, linker = #linker job, link = #link job}
|
ziv@2202
|
1623
|
adam@1381
|
1624 before cleanup ())
|
adamc@274
|
1625 end
|
adamc@274
|
1626 handle ex => (((cleanup ()) handle _ => ()); raise ex)
|
adamc@202
|
1627 end
|
adamc@29
|
1628
|
adamc@1045
|
1629 fun compiler job =
|
adamc@1045
|
1630 if compile job then
|
adamc@1045
|
1631 ()
|
adamc@1045
|
1632 else
|
adamc@1045
|
1633 OS.Process.exit OS.Process.failure
|
adamc@1045
|
1634
|
adamc@1266
|
1635 fun moduleOf fname =
|
adamc@1266
|
1636 let
|
adamc@1266
|
1637 val mrs = !moduleRoots
|
adamc@1266
|
1638 val fname = OS.Path.mkCanonical fname
|
adamc@1266
|
1639 in
|
adamc@1266
|
1640 case List.find (fn (root, _) => String.isPrefix (root ^ "/") fname) mrs of
|
adamc@1266
|
1641 NONE => capitalize (OS.Path.base (OS.Path.file fname))
|
adamc@1266
|
1642 | SOME (root, name) =>
|
adamc@1266
|
1643 let
|
adamc@1266
|
1644 val fname = OS.Path.base fname
|
adamc@1266
|
1645 val fname = String.extract (fname, size root + 1, NONE)
|
adamc@1266
|
1646 val fs = String.fields (fn ch => ch = #"/") fname
|
adamc@1266
|
1647 val fs = List.filter (CharVector.exists (fn ch => not (Char.isDigit ch))) fs
|
adamc@1266
|
1648 val fs = map capitalize fs
|
adamc@1266
|
1649 in
|
adamc@1266
|
1650 String.concatWith "." (name :: fs)
|
adamc@1266
|
1651 end
|
adamc@1266
|
1652 end
|
adamc@1266
|
1653
|
adamc@1
|
1654 end
|