adamc@1: (* Copyright (c) 2008, Adam Chlipala adamc@1: * All rights reserved. adamc@1: * adamc@1: * Redistribution and use in source and binary forms, with or without adamc@1: * modification, are permitted provided that the following conditions are met: adamc@1: * adamc@1: * - Redistributions of source code must retain the above copyright notice, adamc@1: * this list of conditions and the following disclaimer. adamc@1: * - Redistributions in binary form must reproduce the above copyright notice, adamc@1: * this list of conditions and the following disclaimer in the documentation adamc@1: * and/or other materials provided with the distribution. adamc@1: * - The names of contributors may not be used to endorse or promote products adamc@1: * derived from this software without specific prior written permission. adamc@1: * adamc@1: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@1: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@1: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@1: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@1: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@1: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@1: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@1: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@1: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@1: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@1: * POSSIBILITY OF SUCH DAMAGE. adamc@1: *) adamc@1: adamc@1: (* Laconic/Web language parser *) adamc@1: adamc@1: structure Compiler :> COMPILER = struct adamc@1: adamc@1: structure LacwebLrVals = LacwebLrValsFn(structure Token = LrParser.Token) adamc@1: structure Lex = LacwebLexFn(structure Tokens = LacwebLrVals.Tokens) adamc@1: structure LacwebP = Join(structure ParserData = LacwebLrVals.ParserData adamc@1: structure Lex = Lex adamc@1: structure LrParser = LrParser) adamc@1: adamc@55: fun parseLig filename = adamc@55: let adamc@55: val fname = OS.FileSys.tmpName () adamc@55: val outf = TextIO.openOut fname adamc@55: val () = TextIO.output (outf, "sig\n") adamc@55: val inf = TextIO.openIn filename adamc@55: fun loop () = adamc@55: case TextIO.inputLine inf of adamc@55: NONE => () adamc@55: | SOME line => (TextIO.output (outf, line); adamc@55: loop ()) adamc@55: val () = loop () adamc@55: val () = TextIO.closeIn inf adamc@55: val () = TextIO.closeOut outf adamc@55: adamc@55: val () = (ErrorMsg.resetErrors (); adamc@55: ErrorMsg.resetPositioning filename) adamc@55: val file = TextIO.openIn fname adamc@55: fun get _ = TextIO.input file adamc@55: fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s adamc@55: val lexer = LrParser.Stream.streamify (Lex.makeLexer get) adamc@55: val (absyn, _) = LacwebP.parse (30, lexer, parseerror, ()) adamc@55: in adamc@55: TextIO.closeIn file; adamc@55: if ErrorMsg.anyErrors () then adamc@55: NONE adamc@55: else adamc@55: case absyn of adamc@55: [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => SOME sgis adamc@55: | _ => NONE adamc@55: end adamc@55: handle LrParser.ParseError => NONE adamc@55: adamc@55: fun testLig fname = adamc@55: case parseLig fname of adamc@55: NONE => () adamc@55: | SOME sgis => adamc@55: app (fn sgi => (Print.print (SourcePrint.p_sgn_item sgi); adamc@55: print "\n")) sgis adamc@55: adamc@1: (* The main parsing routine *) adamc@56: fun parseLac filename = adamc@1: let adamc@1: val () = (ErrorMsg.resetErrors (); adamc@1: ErrorMsg.resetPositioning filename) adamc@1: val file = TextIO.openIn filename adamc@1: fun get _ = TextIO.input file adamc@1: fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s adamc@1: val lexer = LrParser.Stream.streamify (Lex.makeLexer get) adamc@1: val (absyn, _) = LacwebP.parse (30, lexer, parseerror, ()) adamc@1: in adamc@1: TextIO.closeIn file; adamc@5: if ErrorMsg.anyErrors () then adamc@5: NONE adamc@5: else adamc@55: case absyn of adamc@55: [(Source.DSgn ("?", _), _)] => adamc@55: (ErrorMsg.error "File starts with 'sig'"; adamc@55: NONE) adamc@55: | _ => SOME absyn adamc@1: end adamc@1: handle LrParser.ParseError => NONE adamc@1: adamc@56: fun testLac fname = adamc@56: case parseLac fname of adamc@56: NONE => () adamc@56: | SOME file => (Print.print (SourcePrint.p_file file); adamc@56: print "\n") adamc@56: adamc@56: type job = string list adamc@56: adamc@56: fun capitalize "" = "" adamc@56: | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adamc@56: adamc@56: fun parse fnames = adamc@56: let adamc@109: fun nameOf fname = capitalize (OS.Path.file fname) adamc@109: adamc@56: fun parseOne fname = adamc@56: let adamc@109: val mname = nameOf fname adamc@56: val lac = OS.Path.joinBaseExt {base = fname, ext = SOME "lac"} adamc@56: val lig = OS.Path.joinBaseExt {base = fname, ext = SOME "lig"} adamc@56: adamc@56: val sgnO = adamc@56: if Posix.FileSys.access (lig, []) then adamc@56: case parseLig lig of adamc@56: NONE => NONE adamc@56: | SOME sgis => SOME (Source.SgnConst sgis, {file = lig, adamc@56: first = ErrorMsg.dummyPos, adamc@56: last = ErrorMsg.dummyPos}) adamc@56: else adamc@56: NONE adamc@56: adamc@56: val loc = {file = lac, adamc@56: first = ErrorMsg.dummyPos, adamc@56: last = ErrorMsg.dummyPos} adamc@56: in adamc@56: case parseLac lac of adamc@56: NONE => NONE adamc@56: | SOME ds => adamc@56: SOME (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc) adamc@56: end adamc@56: adamc@109: val ds = List.mapPartial parseOne fnames adamc@109: val ds = adamc@109: let adamc@109: val final = nameOf (List.last fnames) adamc@109: in adamc@109: ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)] adamc@109: end handle Empty => ds adamc@56: in adamc@56: if ErrorMsg.anyErrors () then adamc@56: NONE adamc@56: else adamc@56: SOME ds adamc@56: end adamc@56: adamc@56: fun elaborate job = adamc@56: case parseLig "lib/basis.lig" of adamc@56: NONE => NONE adamc@56: | SOME empty => adamc@56: case parse job of adamc@56: NONE => NONE adamc@56: | SOME file => adamc@56: let adamc@56: val out = Elaborate.elabFile empty ElabEnv.empty file adamc@56: in adamc@56: if ErrorMsg.anyErrors () then adamc@56: NONE adamc@56: else adamc@56: SOME out adamc@56: end adamc@56: adamc@56: fun explify job = adamc@56: case elaborate job of adamc@5: NONE => NONE adamc@5: | SOME file => adamc@38: if ErrorMsg.anyErrors () then adamc@38: NONE adamc@38: else adamc@38: SOME (Explify.explify file) adamc@38: adamc@56: fun corify job = adamc@56: case explify job of adamc@16: NONE => NONE adamc@39: | SOME file => adamc@25: if ErrorMsg.anyErrors () then adamc@25: NONE adamc@25: else adamc@25: SOME (Corify.corify file) adamc@5: adamc@56: fun shake' job = adamc@56: case corify job of adamc@39: NONE => NONE adamc@39: | SOME file => adamc@39: if ErrorMsg.anyErrors () then adamc@39: NONE adamc@39: else adamc@39: SOME (Shake.shake file) adamc@39: adamc@110: fun tag job = adamc@110: case shake' job of adamc@110: NONE => NONE adamc@110: | SOME file => adamc@110: if ErrorMsg.anyErrors () then adamc@110: NONE adamc@110: else adamc@110: SOME (Tag.tag file) adamc@110: adamc@56: fun reduce job = adamc@110: case tag job of adamc@20: NONE => NONE adamc@25: | SOME file => adamc@25: if ErrorMsg.anyErrors () then adamc@25: NONE adamc@25: else adamc@25: SOME (Reduce.reduce (Shake.shake file)) adamc@20: adamc@56: fun shake job = adamc@56: case reduce job of adamc@23: NONE => NONE adamc@25: | SOME file => adamc@25: if ErrorMsg.anyErrors () then adamc@25: NONE adamc@25: else adamc@25: SOME (Shake.shake file) adamc@25: adamc@56: fun monoize job = adamc@56: case shake job of adamc@25: NONE => NONE adamc@25: | SOME file => adamc@25: if ErrorMsg.anyErrors () then adamc@25: NONE adamc@25: else adamc@56: SOME (Monoize.monoize CoreEnv.empty file) adamc@23: adamc@132: fun mono_opt' job = adamc@132: case monoize job of adamc@132: NONE => NONE adamc@132: | SOME file => adamc@132: if ErrorMsg.anyErrors () then adamc@132: NONE adamc@132: else adamc@132: SOME (MonoOpt.optimize file) adamc@132: adamc@131: fun untangle job = adamc@132: case mono_opt' job of adamc@131: NONE => NONE adamc@131: | SOME file => adamc@131: if ErrorMsg.anyErrors () then adamc@131: NONE adamc@131: else adamc@131: SOME (Untangle.untangle file) adamc@131: adamc@133: fun mono_reduce job = adamc@133: case untangle job of adamc@133: NONE => NONE adamc@133: | SOME file => adamc@133: if ErrorMsg.anyErrors () then adamc@133: NONE adamc@133: else adamc@133: SOME (MonoReduce.reduce file) adamc@133: adamc@134: fun mono_shake job = adamc@134: case mono_reduce job of adamc@134: NONE => NONE adamc@134: | SOME file => adamc@134: if ErrorMsg.anyErrors () then adamc@134: NONE adamc@134: else adamc@134: SOME (MonoShake.shake file) adamc@134: adamc@96: fun mono_opt job = adamc@134: case mono_shake job of adamc@96: NONE => NONE adamc@96: | SOME file => adamc@96: if ErrorMsg.anyErrors () then adamc@96: NONE adamc@96: else adamc@96: SOME (MonoOpt.optimize file) adamc@96: adamc@109: fun cjrize job = adamc@96: case mono_opt job of adamc@26: NONE => NONE adamc@26: | SOME file => adamc@26: if ErrorMsg.anyErrors () then adamc@26: NONE adamc@26: else adamc@29: SOME (Cjrize.cjrize file) adamc@29: adamc@56: fun testParse job = adamc@56: case parse job of adamc@5: NONE => print "Failed\n" adamc@1: | SOME file => adamc@5: (Print.print (SourcePrint.p_file file); adamc@5: print "\n") adamc@5: adamc@56: fun testElaborate job = adamc@56: (case elaborate job of adamc@5: NONE => print "Failed\n" adamc@56: | SOME file => adamc@32: (print "Succeeded\n"; adamc@56: Print.print (ElabPrint.p_file ElabEnv.empty file); adamc@5: print "\n")) adamc@5: handle ElabEnv.UnboundNamed n => adamc@5: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@1: adamc@56: fun testExplify job = adamc@56: (case explify job of adamc@38: NONE => print "Failed\n" adamc@38: | SOME file => adamc@56: (Print.print (ExplPrint.p_file ExplEnv.empty file); adamc@38: print "\n")) adamc@38: handle ExplEnv.UnboundNamed n => adamc@38: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@38: adamc@56: fun testCorify job = adamc@56: (case corify job of adamc@16: NONE => print "Failed\n" adamc@16: | SOME file => adamc@56: (Print.print (CorePrint.p_file CoreEnv.empty file); adamc@16: print "\n")) adamc@16: handle CoreEnv.UnboundNamed n => adamc@16: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@16: adamc@56: fun testShake' job = adamc@56: (case shake' job of adamc@39: NONE => print "Failed\n" adamc@39: | SOME file => adamc@56: (Print.print (CorePrint.p_file CoreEnv.empty file); adamc@39: print "\n")) adamc@39: handle CoreEnv.UnboundNamed n => adamc@39: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@39: adamc@110: fun testTag job = adamc@110: (case tag job of adamc@110: NONE => print "Failed\n" adamc@110: | SOME file => adamc@110: (Print.print (CorePrint.p_file CoreEnv.empty file); adamc@110: print "\n")) adamc@110: handle CoreEnv.UnboundNamed n => adamc@110: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@110: adamc@56: fun testReduce job = adamc@131: (case tag job of adamc@20: NONE => print "Failed\n" adamc@20: | SOME file => adamc@56: (Print.print (CorePrint.p_file CoreEnv.empty file); adamc@20: print "\n")) adamc@20: handle CoreEnv.UnboundNamed n => adamc@20: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@20: adamc@56: fun testShake job = adamc@56: (case shake job of adamc@23: NONE => print "Failed\n" adamc@23: | SOME file => adamc@56: (Print.print (CorePrint.p_file CoreEnv.empty file); adamc@23: print "\n")) adamc@23: handle CoreEnv.UnboundNamed n => adamc@23: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@23: adamc@56: fun testMonoize job = adamc@56: (case monoize job of adamc@25: NONE => print "Failed\n" adamc@25: | SOME file => adamc@56: (Print.print (MonoPrint.p_file MonoEnv.empty file); adamc@25: print "\n")) adamc@25: handle MonoEnv.UnboundNamed n => adamc@25: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@25: adamc@132: fun testMono_opt' job = adamc@132: (case mono_opt' job of adamc@132: NONE => print "Failed\n" adamc@132: | SOME file => adamc@132: (Print.print (MonoPrint.p_file MonoEnv.empty file); adamc@132: print "\n")) adamc@132: handle MonoEnv.UnboundNamed n => adamc@132: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@132: adamc@131: fun testUntangle job = adamc@131: (case untangle job of adamc@131: NONE => print "Failed\n" adamc@131: | SOME file => adamc@131: (Print.print (MonoPrint.p_file MonoEnv.empty file); adamc@131: print "\n")) adamc@131: handle MonoEnv.UnboundNamed n => adamc@131: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@131: adamc@133: fun testMono_reduce job = adamc@133: (case mono_reduce job of adamc@133: NONE => print "Failed\n" adamc@133: | SOME file => adamc@133: (Print.print (MonoPrint.p_file MonoEnv.empty file); adamc@133: print "\n")) adamc@133: handle MonoEnv.UnboundNamed n => adamc@133: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@133: adamc@134: fun testMono_shake job = adamc@134: (case mono_shake job of adamc@134: NONE => print "Failed\n" adamc@134: | SOME file => adamc@134: (Print.print (MonoPrint.p_file MonoEnv.empty file); adamc@134: print "\n")) adamc@134: handle MonoEnv.UnboundNamed n => adamc@134: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@134: adamc@96: fun testMono_opt job = adamc@96: (case mono_opt job of adamc@96: NONE => print "Failed\n" adamc@96: | SOME file => adamc@96: (Print.print (MonoPrint.p_file MonoEnv.empty file); adamc@96: print "\n")) adamc@96: handle MonoEnv.UnboundNamed n => adamc@96: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@96: adamc@56: fun testCjrize job = adamc@56: (case cjrize job of adamc@29: NONE => print "Failed\n" adamc@29: | SOME file => adamc@56: (Print.print (CjrPrint.p_file CjrEnv.empty file); adamc@29: print "\n")) adamc@29: handle CjrEnv.UnboundNamed n => adamc@29: print ("Unbound named " ^ Int.toString n ^ "\n") adamc@29: adamc@56: fun compile job = adamc@56: case cjrize job of adamc@114: NONE => print "Laconic compilation failed\n" adamc@29: | SOME file => adamc@29: let adamc@102: val cname = "/tmp/lacweb.c" adamc@102: val oname = "/tmp/lacweb.o" adamc@102: val ename = "/tmp/webapp" adamc@102: adamc@113: val compile = "gcc -O3 -I include -c " ^ cname ^ " -o " ^ oname adamc@113: val link = "gcc -O3 clib/lacweb.o " ^ oname ^ " clib/driver.o -o " ^ ename adamc@102: adamc@102: val outf = TextIO.openOut cname adamc@29: val s = TextIOPP.openOut {dst = outf, wid = 80} adamc@29: in adamc@56: Print.fprint s (CjrPrint.p_file CjrEnv.empty file); adamc@102: TextIO.closeOut outf; adamc@102: adamc@102: if not (OS.Process.isSuccess (OS.Process.system compile)) then adamc@102: print "C compilation failed\n" adamc@102: else if not (OS.Process.isSuccess (OS.Process.system link)) then adamc@102: print "C linking failed\n" adamc@102: else adamc@102: print "Success\n" adamc@29: end adamc@29: adamc@1: end