Mercurial > urweb

annotate src/compiler.sml @ 1185:338be96f8533

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