adam@1677: (* Copyright (c) 2008-2012, Adam Chlipala
adamc@0:  * All rights reserved.
adamc@0:  *
adamc@0:  * Redistribution and use in source and binary forms, with or without
adamc@0:  * modification, are permitted provided that the following conditions are met:
adamc@0:  *
adamc@0:  * - Redistributions of source code must retain the above copyright notice,
adamc@0:  *   this list of conditions and the following disclaimer.
adamc@0:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@0:  *   this list of conditions and the following disclaimer in the documentation
adamc@0:  *   and/or other materials provided with the distribution.
adamc@0:  * - The names of contributors may not be used to endorse or promote products
adamc@0:  *   derived from this software without specific prior written permission.
adamc@0:  *
adamc@0:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@0:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@0:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@0:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@0:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@0:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@0:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@0:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@0:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@0:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@0:  * POSSIBILITY OF SUCH DAMAGE.
adamc@0:  *)
adamc@0: 
adamc@857: val timing = ref false
adamc@1086: val tc = ref false
adamc@857: val sources = ref ([] : string list)
adamc@857: val demo = ref (NONE : (string * bool) option)
adam@1493: val tutorial = ref false
adamc@1170: val css = ref false
adamc@857: 
adam@1540: val () = Compiler.beforeC := MLton.GC.pack
adam@1540: 
adam@1520: fun printVersion () = (print (Config.versionString ^ "\n");
adam@1520: 		       OS.Process.exit OS.Process.success)
adam@1520: fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
adam@1520: 			      OS.Process.exit OS.Process.success)
adam@1520: 
adamc@857: fun doArgs args =
adamc@208:     case args of
adamc@857:         [] => ()
adam@1520:       | "-version" :: rest => 
adam@1520: 	printVersion ()
adam@1520:       | "-numeric-version" :: rest =>
adam@1520: 	printNumericVersion ()
adamc@1170:       | "-css" :: rest =>
adamc@1170:         (css := true;
adamc@1170:          doArgs rest)
adamc@384:       | "-demo" :: prefix :: rest =>
adamc@857:         (demo := SOME (prefix, false);
adamc@857:          doArgs rest)
adamc@501:       | "-guided-demo" :: prefix :: rest =>
adamc@857:         (demo := SOME (prefix, true);
adamc@857:          doArgs rest)
adam@1493:       | "-tutorial" :: rest =>
adam@1493:         (tutorial := true;
adam@1493:          doArgs rest)
adamc@856:       | "-protocol" :: name :: rest =>
adamc@856:         (Settings.setProtocol name;
adamc@857:          doArgs rest)
adam@1335:       | "-prefix" :: prefix :: rest =>
adam@1335:         (Settings.setUrlPrefix prefix;
adam@1335:          doArgs rest)
adamc@891:       | "-db" :: s :: rest =>
adamc@891:         (Settings.setDbstring (SOME s);
adamc@891:          doArgs rest)
adamc@866:       | "-dbms" :: name :: rest =>
adamc@866:         (Settings.setDbms name;
adamc@866:          doArgs rest)
adamc@857:       | "-debug" :: rest =>
adamc@857:         (Settings.setDebug true;
adamc@857:          doArgs rest)
adamc@1178:       | "-verbose" :: rest =>
adamc@1178:         (Compiler.debug := true;
adamc@1178:          doArgs rest)
adamc@857:       | "-timing" :: rest =>
adamc@857:         (timing := true;
adamc@857:          doArgs rest)
adamc@1086:       | "-tc" :: rest =>
adamc@1086:         (tc := true;
adamc@1086:          doArgs rest)
adam@1531:       | "-dumpTypes" :: rest =>
adam@1531:         (Elaborate.dumpTypes := true;
adam@1531:          doArgs rest)
adam@1677:       | "-dumpSource" :: rest =>
adam@1677:         (Compiler.dumpSource := true;
adam@1677:          doArgs rest)
adamc@891:       | "-output" :: s :: rest =>
adamc@891:         (Settings.setExe (SOME s);
adamc@891:          doArgs rest)
adamc@891:       | "-sql" :: s :: rest =>
adamc@891:         (Settings.setSql (SOME s);
adamc@891:          doArgs rest)
adamc@1095:       | "-static" :: rest =>
adamc@1095:         (Settings.setStaticLinking true;
adamc@1095:          doArgs rest)
adamc@1126:       | "-path" :: name :: path :: rest =>
adamc@1126:         (Compiler.addPath (name, path);
adamc@1126:          doArgs rest)
adamc@1126:       | "-root" :: name :: root :: rest =>
adamc@1126:         (Compiler.addModuleRoot (root, name);
adamc@1126:          doArgs rest)
adamc@1164:       | "-sigfile" :: name :: rest =>
adamc@1164:         (Settings.setSigFile (SOME name);
adamc@1164:          doArgs rest)
adamc@1235:       | "-iflow" :: rest =>
adamc@1235:         (Compiler.doIflow := true;
adamc@1235:          doArgs rest)
adamc@1266:       | "-moduleOf" :: fname :: _ =>
adamc@1266:         (print (Compiler.moduleOf fname ^ "\n");
adamc@1266:          OS.Process.exit OS.Process.success)
adam@1301:       | "-noEmacs" :: rest =>
adam@1301:         (Demo.noEmacs := true;
adam@1301:          doArgs rest)
adam@1307:       | "-limit" :: class :: num :: rest =>
adam@1307:         (case Int.fromString num of
adam@1307:              NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1307:            | SOME n =>
adam@1307:              if n < 0 then
adam@1307:                  raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1307:              else
adam@1307:                  Settings.addLimit (class, n);
adam@1307:          doArgs rest)
adamc@208:       | arg :: rest =>
adamc@857:         (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
adamc@857:              raise Fail ("Unknown flag " ^ arg)
adamc@857:          else
adamc@857:              sources := arg :: !sources;
adamc@857:          doArgs rest)
adamc@208: 
adamc@857: val () = doArgs (CommandLine.arguments ())
adamc@208: 
adamc@279: val job =
adamc@857:     case !sources of
adamc@279:         [file] => file
adam@1520:       | _ => printVersion ()
adamc@279: 
adamc@208: val () =
adam@1493:     case (!css, !demo, !tutorial) of
adam@1493:         (true, _, _) =>
adamc@1170:         (case Compiler.run Compiler.toCss job of
adamc@1170:              NONE => OS.Process.exit OS.Process.failure
adamc@1170:            | SOME {Overall = ov, Classes = cl} =>
adamc@1170:              (app (print o Css.inheritableToString) ov;
adamc@1170:               print "\n";
adamc@1170:               app (fn (x, (ins, ots)) =>
adamc@1170:                       (print x;
adamc@1170:                        print " ";
adamc@1170:                        app (print o Css.inheritableToString) ins;
adamc@1170:                        app (print o Css.othersToString) ots;
adamc@1170:                        print "\n")) cl))
adam@1493:       | (_, SOME (prefix, guided), _) =>
adamc@501:         Demo.make {prefix = prefix, dirname = job, guided = guided}
adam@1493:       | (_, _, true) => Tutorial.make job
adamc@1170:       | _ =>
adamc@1086:         if !tc then
adamc@1086:             (Compiler.check Compiler.toElaborate job;
adamc@1086:              if ErrorMsg.anyErrors () then
adamc@1086:                  OS.Process.exit OS.Process.failure
adamc@1086:              else
adamc@1086:                  ())
adamc@1086:         else if !timing then
adamc@384:             Compiler.time Compiler.toCjrize job
adamc@384:         else
adamc@1045:             Compiler.compiler job