Mercurial > urweb

annotate src/compiler.sml @ 55:5c97b7cd912b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Parsing signature files
author Adam Chlipala <adamc@hcoop.net>
date Sun, 22 Jun 2008 11:04:10 -0400
parents 02f42e9a1825
children d3cc191cb25f
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@1 79 fun parse 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@5 101 fun elaborate env filename =
adamc@5 102 case parse filename of
adamc@5 103 NONE => NONE
adamc@5 104 | SOME file =>
adamc@5 105 let
adamc@5 106 val out = Elaborate.elabFile env file
adamc@5 107 in
adamc@5 108 if ErrorMsg.anyErrors () then
adamc@5 109 NONE
adamc@5 110 else
adamc@5 111 SOME out
adamc@5 112 end
adamc@16 113
adamc@38 114 fun explify eenv filename =
adamc@38 115 case elaborate eenv filename of
adamc@38 116 NONE => NONE
adamc@38 117 | SOME (file, _) =>
adamc@38 118 if ErrorMsg.anyErrors () then
adamc@38 119 NONE
adamc@38 120 else
adamc@38 121 SOME (Explify.explify file)
adamc@38 122
adamc@38 123 fun corify eenv filename =
adamc@39 124 case explify eenv filename of
adamc@16 125 NONE => NONE
adamc@39 126 | SOME file =>
adamc@25 127 if ErrorMsg.anyErrors () then
adamc@25 128 NONE
adamc@25 129 else
adamc@25 130 SOME (Corify.corify file)
adamc@5 131
adamc@39 132 fun shake' eenv filename =
adamc@39 133 case corify eenv filename of
adamc@39 134 NONE => NONE
adamc@39 135 | SOME file =>
adamc@39 136 if ErrorMsg.anyErrors () then
adamc@39 137 NONE
adamc@39 138 else
adamc@39 139 SOME (Shake.shake file)
adamc@39 140
adamc@38 141 fun reduce eenv filename =
adamc@38 142 case corify eenv filename of
adamc@20 143 NONE => NONE
adamc@25 144 | SOME file =>
adamc@25 145 if ErrorMsg.anyErrors () then
adamc@25 146 NONE
adamc@25 147 else
adamc@25 148 SOME (Reduce.reduce (Shake.shake file))
adamc@20 149
adamc@38 150 fun shake eenv filename =
adamc@38 151 case reduce eenv filename of
adamc@23 152 NONE => NONE
adamc@25 153 | SOME file =>
adamc@25 154 if ErrorMsg.anyErrors () then
adamc@25 155 NONE
adamc@25 156 else
adamc@25 157 SOME (Shake.shake file)
adamc@25 158
adamc@25 159 fun monoize eenv cenv filename =
adamc@38 160 case shake eenv filename of
adamc@25 161 NONE => NONE
adamc@25 162 | SOME file =>
adamc@25 163 if ErrorMsg.anyErrors () then
adamc@25 164 NONE
adamc@25 165 else
adamc@25 166 SOME (Monoize.monoize cenv file)
adamc@23 167
adamc@26 168 fun cloconv eenv cenv filename =
adamc@26 169 case monoize eenv cenv filename of
adamc@26 170 NONE => NONE
adamc@26 171 | SOME file =>
adamc@26 172 if ErrorMsg.anyErrors () then
adamc@26 173 NONE
adamc@26 174 else
adamc@26 175 SOME (Cloconv.cloconv file)
adamc@26 176
adamc@29 177 fun cjrize eenv cenv filename =
adamc@29 178 case cloconv eenv cenv filename of
adamc@29 179 NONE => NONE
adamc@29 180 | SOME file =>
adamc@29 181 if ErrorMsg.anyErrors () then
adamc@29 182 NONE
adamc@29 183 else
adamc@29 184 SOME (Cjrize.cjrize file)
adamc@29 185
adamc@1 186 fun testParse filename =
adamc@1 187 case parse filename of
adamc@5 188 NONE => print "Failed\n"
adamc@1 189 | SOME file =>
adamc@5 190 (Print.print (SourcePrint.p_file file);
adamc@5 191 print "\n")
adamc@5 192
adamc@5 193 fun testElaborate filename =
adamc@14 194 (case elaborate ElabEnv.basis filename of
adamc@5 195 NONE => print "Failed\n"
adamc@31 196 | SOME (file, _) =>
adamc@32 197 (print "Succeeded\n";
adamc@32 198 Print.print (ElabPrint.p_file ElabEnv.basis file);
adamc@5 199 print "\n"))
adamc@5 200 handle ElabEnv.UnboundNamed n =>
adamc@5 201 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@1 202
adamc@38 203 fun testExplify filename =
adamc@38 204 (case explify ElabEnv.basis filename of
adamc@38 205 NONE => print "Failed\n"
adamc@38 206 | SOME file =>
adamc@38 207 (Print.print (ExplPrint.p_file ExplEnv.basis file);
adamc@38 208 print "\n"))
adamc@38 209 handle ExplEnv.UnboundNamed n =>
adamc@38 210 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@38 211
adamc@16 212 fun testCorify filename =
adamc@38 213 (case corify ElabEnv.basis filename of
adamc@16 214 NONE => print "Failed\n"
adamc@16 215 | SOME file =>
adamc@16 216 (Print.print (CorePrint.p_file CoreEnv.basis file);
adamc@16 217 print "\n"))
adamc@16 218 handle CoreEnv.UnboundNamed n =>
adamc@16 219 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@16 220
adamc@39 221 fun testShake' filename =
adamc@39 222 (case shake' ElabEnv.basis filename of
adamc@39 223 NONE => print "Failed\n"
adamc@39 224 | SOME file =>
adamc@39 225 (Print.print (CorePrint.p_file CoreEnv.basis file);
adamc@39 226 print "\n"))
adamc@39 227 handle CoreEnv.UnboundNamed n =>
adamc@39 228 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@39 229
adamc@20 230 fun testReduce filename =
adamc@38 231 (case reduce ElabEnv.basis filename of
adamc@20 232 NONE => print "Failed\n"
adamc@20 233 | SOME file =>
adamc@20 234 (Print.print (CorePrint.p_file CoreEnv.basis file);
adamc@20 235 print "\n"))
adamc@20 236 handle CoreEnv.UnboundNamed n =>
adamc@20 237 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@20 238
adamc@23 239 fun testShake filename =
adamc@38 240 (case shake ElabEnv.basis filename of
adamc@23 241 NONE => print "Failed\n"
adamc@23 242 | SOME file =>
adamc@23 243 (Print.print (CorePrint.p_file CoreEnv.basis file);
adamc@23 244 print "\n"))
adamc@23 245 handle CoreEnv.UnboundNamed n =>
adamc@23 246 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@23 247
adamc@25 248 fun testMonoize filename =
adamc@25 249 (case monoize ElabEnv.basis CoreEnv.basis filename of
adamc@25 250 NONE => print "Failed\n"
adamc@25 251 | SOME file =>
adamc@25 252 (Print.print (MonoPrint.p_file MonoEnv.basis file);
adamc@25 253 print "\n"))
adamc@25 254 handle MonoEnv.UnboundNamed n =>
adamc@25 255 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@25 256
adamc@26 257 fun testCloconv filename =
adamc@26 258 (case cloconv ElabEnv.basis CoreEnv.basis filename of
adamc@26 259 NONE => print "Failed\n"
adamc@26 260 | SOME file =>
adamc@26 261 (Print.print (FlatPrint.p_file FlatEnv.basis file);
adamc@26 262 print "\n"))
adamc@26 263 handle FlatEnv.UnboundNamed n =>
adamc@26 264 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@26 265
adamc@29 266 fun testCjrize filename =
adamc@29 267 (case cjrize ElabEnv.basis CoreEnv.basis filename of
adamc@29 268 NONE => print "Failed\n"
adamc@29 269 | SOME file =>
adamc@29 270 (Print.print (CjrPrint.p_file CjrEnv.basis file);
adamc@29 271 print "\n"))
adamc@29 272 handle CjrEnv.UnboundNamed n =>
adamc@29 273 print ("Unbound named " ^ Int.toString n ^ "\n")
adamc@29 274
adamc@29 275 fun compile filename =
adamc@29 276 case cjrize ElabEnv.basis CoreEnv.basis filename of
adamc@29 277 NONE => ()
adamc@29 278 | SOME file =>
adamc@29 279 let
adamc@29 280 val outf = TextIO.openOut "/tmp/lacweb.c"
adamc@29 281 val s = TextIOPP.openOut {dst = outf, wid = 80}
adamc@29 282 in
adamc@29 283 Print.fprint s (CjrPrint.p_file CjrEnv.basis file);
adamc@29 284 TextIO.closeOut outf
adamc@29 285 end
adamc@29 286
adamc@1 287 end