Mercurial > urweb

changeset 54:a6e185c7c428

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Lexer/parser hacks to share code between regular and signature file parsers
author Adam Chlipala <adamc@hcoop.net>
date Sun, 22 Jun 2008 10:53:11 -0400
parents 4f641f8fddaa
children 5c97b7cd912b
files src/lacweb.grm src/lacweb.lex src/main.mlton.sml tests/lexerr.lac tests/lexerrS.lac
diffstat 5 files changed, 77 insertions(+), 49 deletions(-) [+]
line wrap: on
line diff
--- a/src/lacweb.grm	Sun Jun 22 10:21:38 2008 -0400
+++ b/src/lacweb.grm	Sun Jun 22 10:53:11 2008 -0400
@@ -97,6 +97,8 @@
 %%
 
 file   : decls                          (decls)
+       | SIG sgis                       ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
+                                           s (SIGleft, sgisright))])
 
 decls  :                                ([])
        | decl decls                     (decl :: decls)
--- a/src/lacweb.lex	Sun Jun 22 10:21:38 2008 -0400
+++ b/src/lacweb.lex	Sun Jun 22 10:53:11 2008 -0400
@@ -62,6 +62,25 @@
 val str = ref ([] : char list)
 val strStart = ref 0
 
+local
+    val initSig = ref false
+    val offset = ref 0
+in
+
+fun initialSig () = initSig := true
+
+fun pos yypos = yypos - !offset
+
+fun newline yypos =
+    if !initSig then
+        (initSig := false;
+         offset := yypos + 1)
+    else
+        ErrorMsg.newline (pos yypos)
+
+end
+
+
 %%
 %header (functor LacwebLexFn(structure Tokens : Lacweb_TOKENS));
 %full
@@ -75,87 +94,87 @@
 
 %%
 
-<INITIAL> \n          => (ErrorMsg.newline yypos;
+<INITIAL> \n          => (newline yypos;
                           continue ());
-<COMMENT> \n          => (ErrorMsg.newline yypos;
+<COMMENT> \n          => (newline yypos;
                           continue ());
 
 <INITIAL> {ws}+       => (lex ());
 
 <INITIAL> "(*"        => (YYBEGIN COMMENT;
-                          enterComment yypos;
+                          enterComment (pos yypos);
                           continue ());
-<INITIAL> "*)"        => (ErrorMsg.errorAt' (yypos, yypos) "Unbalanced comments";
+<INITIAL> "*)"        => (ErrorMsg.errorAt' (pos yypos, pos yypos) "Unbalanced comments";
 			  continue ());
 
-<COMMENT> "(*"        => (enterComment yypos;
+<COMMENT> "(*"        => (enterComment (pos yypos);
                           continue ());
 <COMMENT> "*)"        => (if exitComment () then YYBEGIN INITIAL else ();
 			  continue ());
 
-<INITIAL> "\""        => (YYBEGIN STRING; strStart := yypos; str := []; continue());
+<INITIAL> "\""        => (YYBEGIN STRING; strStart := pos yypos; str := []; continue());
 <STRING> "\\\""       => (str := #"\"" :: !str; continue());
 <STRING> "\""         => (YYBEGIN INITIAL;
-			  Tokens.STRING (String.implode (List.rev (!str)), !strStart, yypos + 1));
-<STRING> "\n"         => (ErrorMsg.newline yypos;
+			  Tokens.STRING (String.implode (List.rev (!str)), !strStart, pos yypos + 1));
+<STRING> "\n"         => (newline yypos;
 			  str := #"\n" :: !str; continue());
 <STRING> .            => (str := String.sub (yytext, 0) :: !str; continue());
 
-<INITIAL> "("         => (Tokens.LPAREN (yypos, yypos + size yytext));
-<INITIAL> ")"         => (Tokens.RPAREN (yypos, yypos + size yytext));
-<INITIAL> "["         => (Tokens.LBRACK (yypos, yypos + size yytext));
-<INITIAL> "]"         => (Tokens.RBRACK (yypos, yypos + size yytext));
-<INITIAL> "{"         => (Tokens.LBRACE (yypos, yypos + size yytext));
-<INITIAL> "}"         => (Tokens.RBRACE (yypos, yypos + size yytext));
+<INITIAL> "("         => (Tokens.LPAREN (pos yypos, pos yypos + size yytext));
+<INITIAL> ")"         => (Tokens.RPAREN (pos yypos, pos yypos + size yytext));
+<INITIAL> "["         => (Tokens.LBRACK (pos yypos, pos yypos + size yytext));
+<INITIAL> "]"         => (Tokens.RBRACK (pos yypos, pos yypos + size yytext));
+<INITIAL> "{"         => (Tokens.LBRACE (pos yypos, pos yypos + size yytext));
+<INITIAL> "}"         => (Tokens.RBRACE (pos yypos, pos yypos + size yytext));
 
-<INITIAL> "->"        => (Tokens.ARROW (yypos, yypos + size yytext));
-<INITIAL> "=>"        => (Tokens.DARROW (yypos, yypos + size yytext));
-<INITIAL> "++"        => (Tokens.PLUSPLUS (yypos, yypos + size yytext));
+<INITIAL> "->"        => (Tokens.ARROW (pos yypos, pos yypos + size yytext));
+<INITIAL> "=>"        => (Tokens.DARROW (pos yypos, pos yypos + size yytext));
+<INITIAL> "++"        => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext));
 
-<INITIAL> "="         => (Tokens.EQ (yypos, yypos + size yytext));
-<INITIAL> ","         => (Tokens.COMMA (yypos, yypos + size yytext));
-<INITIAL> ":::"       => (Tokens.TCOLON (yypos, yypos + size yytext));
-<INITIAL> "::"        => (Tokens.DCOLON (yypos, yypos + size yytext));
-<INITIAL> ":"         => (Tokens.COLON (yypos, yypos + size yytext));
-<INITIAL> "."         => (Tokens.DOT (yypos, yypos + size yytext));
-<INITIAL> "$"         => (Tokens.DOLLAR (yypos, yypos + size yytext));
-<INITIAL> "#"         => (Tokens.HASH (yypos, yypos + size yytext));
-<INITIAL> "__"        => (Tokens.UNDERUNDER (yypos, yypos + size yytext));
-<INITIAL> "_"         => (Tokens.UNDER (yypos, yypos + size yytext));
+<INITIAL> "="         => (Tokens.EQ (pos yypos, pos yypos + size yytext));
+<INITIAL> ","         => (Tokens.COMMA (pos yypos, pos yypos + size yytext));
+<INITIAL> ":::"       => (Tokens.TCOLON (pos yypos, pos yypos + size yytext));
+<INITIAL> "::"        => (Tokens.DCOLON (pos yypos, pos yypos + size yytext));
+<INITIAL> ":"         => (Tokens.COLON (pos yypos, pos yypos + size yytext));
+<INITIAL> "."         => (Tokens.DOT (pos yypos, pos yypos + size yytext));
+<INITIAL> "$"         => (Tokens.DOLLAR (pos yypos, pos yypos + size yytext));
+<INITIAL> "#"         => (Tokens.HASH (pos yypos, pos yypos + size yytext));
+<INITIAL> "__"        => (Tokens.UNDERUNDER (pos yypos, pos yypos + size yytext));
+<INITIAL> "_"         => (Tokens.UNDER (pos yypos, pos yypos + size yytext));
 
-<INITIAL> "con"       => (Tokens.CON (yypos, yypos + size yytext));
-<INITIAL> "type"      => (Tokens.LTYPE (yypos, yypos + size yytext));
-<INITIAL> "val"       => (Tokens.VAL (yypos, yypos + size yytext));
-<INITIAL> "fn"        => (Tokens.FN (yypos, yypos + size yytext));
+<INITIAL> "con"       => (Tokens.CON (pos yypos, pos yypos + size yytext));
+<INITIAL> "type"      => (Tokens.LTYPE (pos yypos, pos yypos + size yytext));
+<INITIAL> "val"       => (Tokens.VAL (pos yypos, pos yypos + size yytext));
+<INITIAL> "fn"        => (Tokens.FN (pos yypos, pos yypos + size yytext));
 
-<INITIAL> "structure" => (Tokens.STRUCTURE (yypos, yypos + size yytext));
-<INITIAL> "signature" => (Tokens.SIGNATURE (yypos, yypos + size yytext));
-<INITIAL> "struct"    => (Tokens.STRUCT (yypos, yypos + size yytext));
-<INITIAL> "sig"       => (Tokens.SIG (yypos, yypos + size yytext));
-<INITIAL> "end"       => (Tokens.END (yypos, yypos + size yytext));
-<INITIAL> "functor"   => (Tokens.FUNCTOR (yypos, yypos + size yytext));
-<INITIAL> "where"     => (Tokens.WHERE (yypos, yypos + size yytext));
-<INITIAL> "extern"    => (Tokens.EXTERN (yypos, yypos + size yytext));
+<INITIAL> "structure" => (Tokens.STRUCTURE (pos yypos, pos yypos + size yytext));
+<INITIAL> "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext));
+<INITIAL> "struct"    => (Tokens.STRUCT (pos yypos, pos yypos + size yytext));
+<INITIAL> "sig"       => (if yypos = 2 then initialSig () else (); Tokens.SIG (pos yypos, pos yypos + size yytext));
+<INITIAL> "end"       => (Tokens.END (pos yypos, pos yypos + size yytext));
+<INITIAL> "functor"   => (Tokens.FUNCTOR (pos yypos, pos yypos + size yytext));
+<INITIAL> "where"     => (Tokens.WHERE (pos yypos, pos yypos + size yytext));
+<INITIAL> "extern"    => (Tokens.EXTERN (pos yypos, pos yypos + size yytext));
 
-<INITIAL> "Type"      => (Tokens.TYPE (yypos, yypos + size yytext));
-<INITIAL> "Name"      => (Tokens.NAME (yypos, yypos + size yytext));
+<INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
+<INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
 
-<INITIAL> {id}        => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext));
-<INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, yypos, yypos + size yytext));
+<INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
+<INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
 
 <INITIAL> {intconst}  => (case Int64.fromString yytext of
-                            SOME x => Tokens.INT (x, yypos, yypos + size yytext)
-                          | NONE   => (ErrorMsg.errorAt' (yypos, yypos)
+                            SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
+                          | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
                                        ("Expected int, received: " ^ yytext);
                                        continue ()));
 <INITIAL> {realconst} => (case Real64.fromString yytext of
-                            SOME x => Tokens.FLOAT (x, yypos, yypos + size yytext)
-                          | NONE   => (ErrorMsg.errorAt' (yypos, yypos)
+                            SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext)
+                          | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
                                        ("Expected float, received: " ^ yytext);
                                        continue ()));
 
 <COMMENT> .           => (continue());
 
-<INITIAL> .           => (ErrorMsg.errorAt' (yypos, yypos)
+<INITIAL> .           => (ErrorMsg.errorAt' (pos yypos, pos yypos)
                                             ("illegal character: \"" ^ yytext ^ "\"");
                           continue ());
--- a/src/main.mlton.sml	Sun Jun 22 10:21:38 2008 -0400
+++ b/src/main.mlton.sml	Sun Jun 22 10:53:11 2008 -0400
@@ -26,5 +26,5 @@
  *)
 
 val () = case CommandLine.arguments () of
-             [filename] => Compiler.testCloconv filename
+             [filename] => Compiler.testCjrize filename
            | _ => print "Bad arguments"
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/lexerr.lac	Sun Jun 22 10:53:11 2008 -0400
@@ -0,0 +1,3 @@
+type t = int
+type q = int
+type u = inot
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/lexerrS.lac	Sun Jun 22 10:53:11 2008 -0400
@@ -0,0 +1,4 @@
+sig
+type t = int
+type q = int
+type u = inot