Mercurial > urweb

annotate src/compiler.sml @ 1132:d4cd54a4ea06

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