Mercurial > urweb

annotate src/compiler.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents 5f04adf47f48
children 3739af9e727a
rev   line source
adamc@1 1 (* Copyright (c) 2008, 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 (* Laconic/Web language parser *)
adamc@1 29
adamc@1 30 structure Compiler :> COMPILER = struct
adamc@1 31
adamc@1 32 structure LacwebLrVals = LacwebLrValsFn(structure Token = LrParser.Token)
adamc@1 33 structure Lex = LacwebLexFn(structure Tokens = LacwebLrVals.Tokens)
adamc@1 34 structure LacwebP = Join(structure ParserData = LacwebLrVals.ParserData
adamc@1 35 structure Lex = Lex
adamc@1 36 structure LrParser = LrParser)
adamc@1 37
adamc@55 38 fun parseLig filename =
adamc@55 39 let
adamc@55 40 val fname = OS.FileSys.tmpName ()
adamc@55 41 val outf = TextIO.openOut fname
adamc@55 42 val () = TextIO.output (outf, "sig\n")
adamc@55 43 val inf = TextIO.openIn filename
adamc@55 44 fun loop () =
adamc@55 45 case TextIO.inputLine inf of
adamc@55 46 NONE => ()
adamc@55 47 | SOME line => (TextIO.output (outf, line);
adamc@55 48 loop ())
adamc@55 49 val () = loop ()
adamc@55 50 val () = TextIO.closeIn inf
adamc@55 51 val () = TextIO.closeOut outf
adamc@55 52
adamc@55 53 val () = (ErrorMsg.resetErrors ();
adamc@55 54 ErrorMsg.resetPositioning filename)
adamc@55 55 val file = TextIO.openIn fname
adamc@55 56 fun get _ = TextIO.input file
adamc@55 57 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@55 58 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@55 59 val (absyn, _) = LacwebP.parse (30, lexer, parseerror, ())
adamc@55 60 in
adamc@55 61 TextIO.closeIn file;
adamc@55 62 if ErrorMsg.anyErrors () then
adamc@55 63 NONE
adamc@55 64 else
adamc@55 65 case absyn of
adamc@55 66 [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => SOME sgis
adamc@55 67 | _ => NONE
adamc@55 68 end
adamc@55 69 handle LrParser.ParseError => NONE
adamc@55 70
adamc@55 71 fun testLig fname =
adamc@55 72 case parseLig fname of
adamc@55 73 NONE => ()
adamc@55 74 | SOME sgis =>
adamc@55 75 app (fn sgi => (Print.print (SourcePrint.p_sgn_item sgi);
adamc@55 76 print "\n")) sgis
adamc@55 77
adamc@1 78 (* The main parsing routine *)
adamc@56 79 fun parseLac filename =
adamc@1 80 let
adamc@1 81 val () = (ErrorMsg.resetErrors ();
adamc@1 82 ErrorMsg.resetPositioning filename)
adamc@1 83 val file = TextIO.openIn filename
adamc@1 84 fun get _ = TextIO.input file
adamc@1 85 fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
adamc@1 86 val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
adamc@1 87 val (absyn, _) = LacwebP.parse (30, lexer, parseerror, ())
adamc@1 88 in
adamc@1 89 TextIO.closeIn file;
adamc@5 90 if ErrorMsg.anyErrors () then
adamc@5 91 NONE
adamc@5 92 else
adamc@55 93 case absyn of
adamc@55 94 [(Source.DSgn ("?", _), _)] =>
adamc@55 95 (ErrorMsg.error "File starts with 'sig'";
adamc@55 96 NONE)
adamc@55 97 | _ => SOME absyn
adamc@1 98 end
adamc@1 99 handle LrParser.ParseError => NONE
adamc@1 100
adamc@56 101 fun testLac fname =
adamc@56 102 case parseLac fname of
adamc@56 103 NONE => ()
adamc@56 104 | SOME file => (Print.print (SourcePrint.p_file file);
adamc@56 105 print "\n")
adamc@56 106
adamc@56 107 type job = string list
adamc@56 108
adamc@56 109 fun capitalize "" = ""
adamc@56 110 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@56 111
adamc@56 112 fun parse fnames =
adamc@56 113 let
adamc@109 114 fun nameOf fname = capitalize (OS.Path.file fname)
adamc@109 115
adamc@56 116 fun parseOne fname =
adamc@56 117 let
adamc@109 118 val mname = nameOf fname
adamc@56 119 val lac = OS.Path.joinBaseExt {base = fname, ext = SOME "lac"}
adamc@56 120 val lig = OS.Path.joinBaseExt {base = fname, ext = SOME "lig"}
adamc@56 121
adamc@56 122 val sgnO =
adamc@56 123 if Posix.FileSys.access (lig, []) then
adamc@56 124 case parseLig lig of
adamc@56 125 NONE => NONE
adamc@56 126 | SOME sgis => SOME (Source.SgnConst sgis, {file = lig,
adamc@56 127 first = ErrorMsg.dummyPos,
adamc@56 128 last = ErrorMsg.dummyPos})
adamc@56 129 else
adamc@56 130 NONE
adamc@56 131
adamc@56 132 val loc = {file = lac,
adamc@56 133 first = ErrorMsg.dummyPos,
adamc@56 134 last = ErrorMsg.dummyPos}
adamc@56 135 in
adamc@56 136 case parseLac lac of
adamc@56 137 NONE => NONE
adamc@56 138 | SOME ds =>
adamc@56 139 SOME (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
adamc@56 140 end
adamc@56 141
adamc@109 142 val ds = List.mapPartial parseOne fnames
adamc@109 143 val ds =
adamc@109 144 let
adamc@109 145 val final = nameOf (List.last fnames)
adamc@109 146 in
adamc@109 147 ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
adamc@109 148 end handle Empty => ds
adamc@56 149 in
adamc@56 150 if ErrorMsg.anyErrors () then
adamc@56 151 NONE
adamc@56 152 else
adamc@56 153 SOME ds
adamc@56 154 end
adamc@56 155
adamc@56 156 fun elaborate job =
adamc@56 157 case parseLig "lib/basis.lig" of
adamc@56 158 NONE => NONE
adamc@56 159 | SOME empty =>
adamc@56 160 case parse job of
adamc@56 161 NONE => NONE
adamc@56 162 | SOME file =>
adamc@56 163 let
adamc@56 164 val out = Elaborate.elabFile empty ElabEnv.empty file
adamc@56 165 in
adamc@56 166 if ErrorMsg.anyErrors () then
adamc@56 167 NONE
adamc@56 168 else
adamc@56 169 SOME out
adamc@56 170 end
adamc@56 171
adamc@56 172 fun explify job =
adamc@56 173 case elaborate job of
adamc@5 174 NONE => NONE
adamc@5 175 | SOME file =>
adamc@38 176 if ErrorMsg.anyErrors () then
adamc@38 177 NONE
adamc@38 178 else
adamc@38 179 SOME (Explify.explify file)
adamc@38 180
adamc@56 181 fun corify job =
adamc@56 182 case explify job of
adamc@16 183 NONE => NONE
adamc@39 184 | SOME file =>
adamc@25 185 if ErrorMsg.anyErrors () then
adamc@25 186 NONE
adamc@25 187 else
adamc@25 188 SOME (Corify.corify file)
adamc@5 189
adamc@56 190 fun shake' job =
adamc@56 191 case corify job of
adamc@39 192 NONE => NONE
adamc@39 193 | SOME file =>
adamc@39 194 if ErrorMsg.anyErrors () then
adamc@39 195 NONE
adamc@39 196 else
adamc@39 197 SOME (Shake.shake file)
adamc@39 198
adamc@56 199 fun reduce job =
adamc@56 200 case corify job of
adamc@20 201 NONE => NONE
adamc@25 202 | SOME file =>
adamc@25 203 if ErrorMsg.anyErrors () then
adamc@25 204 NONE
adamc@25 205 else
adamc@25 206 SOME (Reduce.reduce (Shake.shake file))
adamc@20 207
adamc@56 208 fun shake job =
adamc@56 209 case reduce job of
adamc@23 210 NONE => NONE
adamc@25 211 | SOME file =>
adamc@25 212 if ErrorMsg.anyErrors () then
adamc@25 213 NONE
adamc@25 214 else
adamc@25 215 SOME (Shake.shake file)
adamc@25 216
adamc@56 217 fun monoize job =
adamc@56 218 case shake job of
adamc@25 219 NONE => NONE
adamc@25 220 | SOME file =>
adamc@25 221 if ErrorMsg.anyErrors () then
adamc@25 222 NONE
adamc@25 223 else
adamc@56 224 SOME (Monoize.monoize CoreEnv.empty file)
adamc@23 225
adamc@96 226 fun mono_opt job =
adamc@96 227 case monoize job of
adamc@96 228 NONE => NONE
adamc@96 229 | SOME file =>
adamc@96 230 if ErrorMsg.anyErrors () then
adamc@96 231 NONE
adamc@96 232 else
adamc@96 233 SOME (MonoOpt.optimize file)
adamc@96 234
adamc@109 235 fun cjrize job =
adamc@96 236 case mono_opt job of
adamc@26 237 NONE => NONE
adamc@26 238 | SOME file =>
adamc@26 239 if ErrorMsg.anyErrors () then
adamc@26 240 NONE
adamc@26 241 else
adamc@29 242 SOME (Cjrize.cjrize file)
adamc@29 243
adamc@56 244 fun testParse job =
adamc@56 245 case parse job of
adamc@5 246 NONE => print "Failed\n"
adamc@1 247 | SOME file =>
adamc@5 248 (Print.print (SourcePrint.p_file file);
adamc@5 249 print "\n")
adamc@5 250
adamc@56 251 fun testElaborate job =
adamc@56 252 (case elaborate job of
adamc@5 253 NONE => print "Failed\n"
adamc@56 254 | SOME file =>
adamc@32 255 (print "Succeeded\n";
adamc@56 256 Print.print (ElabPrint.p_file ElabEnv.empty file);
adamc@5 257 print "\n"))
adamc@5 258 handle ElabEnv.UnboundNamed n =>
adamc@5 259 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@1 260
adamc@56 261 fun testExplify job =
adamc@56 262 (case explify job of
adamc@38 263 NONE => print "Failed\n"
adamc@38 264 | SOME file =>
adamc@56 265 (Print.print (ExplPrint.p_file ExplEnv.empty file);
adamc@38 266 print "\n"))
adamc@38 267 handle ExplEnv.UnboundNamed n =>
adamc@38 268 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@38 269
adamc@56 270 fun testCorify job =
adamc@56 271 (case corify job of
adamc@16 272 NONE => print "Failed\n"
adamc@16 273 | SOME file =>
adamc@56 274 (Print.print (CorePrint.p_file CoreEnv.empty file);
adamc@16 275 print "\n"))
adamc@16 276 handle CoreEnv.UnboundNamed n =>
adamc@16 277 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@16 278
adamc@56 279 fun testShake' job =
adamc@56 280 (case shake' job of
adamc@39 281 NONE => print "Failed\n"
adamc@39 282 | SOME file =>
adamc@56 283 (Print.print (CorePrint.p_file CoreEnv.empty file);
adamc@39 284 print "\n"))
adamc@39 285 handle CoreEnv.UnboundNamed n =>
adamc@39 286 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@39 287
adamc@56 288 fun testReduce job =
adamc@56 289 (case reduce job of
adamc@20 290 NONE => print "Failed\n"
adamc@20 291 | SOME file =>
adamc@56 292 (Print.print (CorePrint.p_file CoreEnv.empty file);
adamc@20 293 print "\n"))
adamc@20 294 handle CoreEnv.UnboundNamed n =>
adamc@20 295 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@20 296
adamc@56 297 fun testShake job =
adamc@56 298 (case shake job of
adamc@23 299 NONE => print "Failed\n"
adamc@23 300 | SOME file =>
adamc@56 301 (Print.print (CorePrint.p_file CoreEnv.empty file);
adamc@23 302 print "\n"))
adamc@23 303 handle CoreEnv.UnboundNamed n =>
adamc@23 304 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@23 305
adamc@56 306 fun testMonoize job =
adamc@56 307 (case monoize job of
adamc@25 308 NONE => print "Failed\n"
adamc@25 309 | SOME file =>
adamc@56 310 (Print.print (MonoPrint.p_file MonoEnv.empty file);
adamc@25 311 print "\n"))
adamc@25 312 handle MonoEnv.UnboundNamed n =>
adamc@25 313 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@25 314
adamc@96 315 fun testMono_opt job =
adamc@96 316 (case mono_opt job of
adamc@96 317 NONE => print "Failed\n"
adamc@96 318 | SOME file =>
adamc@96 319 (Print.print (MonoPrint.p_file MonoEnv.empty file);
adamc@96 320 print "\n"))
adamc@96 321 handle MonoEnv.UnboundNamed n =>
adamc@96 322 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@96 323
adamc@56 324 fun testCjrize job =
adamc@56 325 (case cjrize job of
adamc@29 326 NONE => print "Failed\n"
adamc@29 327 | SOME file =>
adamc@56 328 (Print.print (CjrPrint.p_file CjrEnv.empty file);
adamc@29 329 print "\n"))
adamc@29 330 handle CjrEnv.UnboundNamed n =>
adamc@29 331 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@29 332
adamc@56 333 fun compile job =
adamc@56 334 case cjrize job of
adamc@29 335 NONE => ()
adamc@29 336 | SOME file =>
adamc@29 337 let
adamc@102 338 val cname = "/tmp/lacweb.c"
adamc@102 339 val oname = "/tmp/lacweb.o"
adamc@102 340 val ename = "/tmp/webapp"
adamc@102 341
adamc@102 342 val compile = "gcc -I include -c " ^ cname ^ " -o " ^ oname
adamc@102 343 val link = "gcc clib/lacweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
adamc@102 344
adamc@102 345 val outf = TextIO.openOut cname
adamc@29 346 val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@29 347 in
adamc@56 348 Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
adamc@102 349 TextIO.closeOut outf;
adamc@102 350
adamc@102 351 if not (OS.Process.isSuccess (OS.Process.system compile)) then
adamc@102 352 print "C compilation failed\n"
adamc@102 353 else if not (OS.Process.isSuccess (OS.Process.system link)) then
adamc@102 354 print "C linking failed\n"
adamc@102 355 else
adamc@102 356 print "Success\n"
adamc@29 357 end
adamc@29 358
adamc@1 359 end