Switched the keyword from string to a sum type

11 files changed, 89 insertions, 83 deletions

diff --git a/lib/qparser/idents.ml b/lib/qparser/idents.ml
index baf23dc..02fbac2 100644
--- a/lib/qparser/idents.ml
+++ b/lib/qparser/idents.ml
@@ -8,10 +8,10 @@ let _ =
     (fun (kwd, tok) -> Hashtbl.add keyword_table kwd tok)
     [
       ("ACT", ACT);
-      ("ADDLIB", KEYWORD "INCLIB");
-      ("ADDOBJ", KEYWORD "ADDOBJ");
-      ("ADD OBJ", KEYWORD "ADDOBJ");
-      ("ADDQST", KEYWORD "INCLIB");
+      ("ADDLIB", KEYWORD T.IncLib);
+      ("ADDOBJ", KEYWORD T.Addobj);
+      ("ADD OBJ", KEYWORD T.Addobj);
+      ("ADDQST", KEYWORD T.IncLib);
       ("AND", AND);
       ("ARRCOMP", FUNCTION T.Arrcomp);
       ("ARRPOS", FUNCTION T.Arrpos);
@@ -20,17 +20,17 @@ let _ =
         ; "BACKIMAGE",        KEYWORD "BACKIMAGE"
         ; "$BACKIMAGE",       KEYWORD "BACKIMAGE"
         ; "BCOLOR",           KEYWORD "BCOLOR" *);
-      ("CLA", KEYWORD "CLA");
-      ("CLEAR", KEYWORD "CLEAR");
-      ("*CLEAR", KEYWORD "*CLEAR");
-      ("CLOSE", KEYWORD "CLOSE");
-      ("CLOSE ALL", KEYWORD "CLOSEALL");
-      ("CLR", KEYWORD "CLEAR");
-      ("*CLR", KEYWORD "*CLEAR");
-      ("CLS", KEYWORD "CLS");
-      ("CMDCLEAR", KEYWORD "CMDCLEAR");
-      ("CMDCLR", KEYWORD "CMDCLEAR");
-      ("COPYARR", KEYWORD "COPYARR");
+      ("CLA", KEYWORD T.Cla);
+      ("CLEAR", KEYWORD T.Clear);
+      ("*CLEAR", KEYWORD T.Clear');
+      ("CLOSE", KEYWORD T.Close);
+      ("CLOSE ALL", KEYWORD T.CloseAll);
+      ("CLR", KEYWORD T.Clear);
+      ("*CLR", KEYWORD T.Clear');
+      ("CLS", KEYWORD T.Cls);
+      ("CMDCLEAR", KEYWORD T.CmdClear);
+      ("CMDCLR", KEYWORD T.CmdClear);
+      ("COPYARR", KEYWORD T.CopyArr);
       ("COUNTOBJ", FUNCTION T.Countobj);
       ("CURACTS", IDENT "CURACTS");
       ("$CURACTS", IDENT "$CURACTS");
@@ -39,30 +39,30 @@ let _ =
       (*
         ; "DEBUG",            KEYWORD "DEBUG"
 *);
-      ("DELACT", KEYWORD "DELACT");
-      ("DEL ACT", KEYWORD "DELACT");
-      ("DELLIB", KEYWORD "FREELIB");
-      ("DELOBJ", KEYWORD "DELOBJ");
-      ("DEL OBJ", KEYWORD "DELOBJ");
+      ("DELACT", KEYWORD T.DelAct);
+      ("DEL ACT", KEYWORD T.DelAct);
+      ("DELLIB", KEYWORD T.FreeLib);
+      ("DELOBJ", KEYWORD T.DelObj);
+      ("DEL OBJ", KEYWORD T.DelObj);
       ("DESC", FUNCTION T.Desc);
       ("$DESC", FUNCTION T.Desc')
       (*
         ; "DISABLESCROLL",    KEYWORD "DISABLESCROLL"
         ; "DISABLESUBEX",     KEYWORD "DISABLESUBEX"
 *);
-      ("DYNAMIC", KEYWORD "DYNAMIC");
+      ("DYNAMIC", KEYWORD T.Dynamic);
       ("DYNEVAL", FUNCTION T.Dyneval);
       ("$DYNEVAL", FUNCTION T.Dyneval');
       ("ELSE", ELSE);
       ("ELSEIF", ELIF);
       ("END", END);
-      ("EXEC", KEYWORD "EXEC");
-      ("EXIT", KEYWORD "EXIT")
+      ("EXEC", KEYWORD T.Exec);
+      ("EXIT", KEYWORD T.Exit)
       (*
         ; "FCOLOR",           KEYWORD "FCOLOR"
         ; "$FNAME",           KEYWORD "$FNAME"
 *);
-      ("FREELIB", KEYWORD "FREELIB")
+      ("FREELIB", KEYWORD T.FreeLib)
       (*
         ; "FSIZE",            KEYWORD "FSIZE"
 *);
@@ -70,26 +70,26 @@ let _ =
       ("$FUNC", FUNCTION T.Func');
       ("GETOBJ", FUNCTION T.Getobj);
       ("$GETOBJ", FUNCTION T.Getobj');
-      ("GOSUB", KEYWORD "GOSUB");
-      ("GOTO", KEYWORD "GOTO") (*
+      ("GOSUB", KEYWORD T.Gosub);
+      ("GOTO", KEYWORD T.Goto) (*
         ; "GC",               KEYWORD "GC"
 *);
-      ("GS", KEYWORD "GOSUB");
-      ("GT", KEYWORD "GOTO");
+      ("GS", KEYWORD T.Gosub);
+      ("GT", KEYWORD T.Goto);
       ("IF", IF);
       ("IIF", FUNCTION T.Iif);
       ("$IIF", FUNCTION T.Iif');
-      ("INCLIB", KEYWORD "INCLIB");
+      ("INCLIB", KEYWORD T.IncLib);
       ("INPUT", FUNCTION T.Input);
       ("$INPUT", FUNCTION T.Input');
       ("INSTR", FUNCTION T.Instr);
       ("ISNUM", FUNCTION T.Isnum);
       ("ISPLAY", FUNCTION T.Isplay);
-      ("JUMP", KEYWORD "JUMP");
-      ("KILLALL", KEYWORD "KILLALL");
-      ("KILLOBJ", KEYWORD "KILLOBJ");
-      ("KILLQST", KEYWORD "FREELIB");
-      ("KILLVAR", KEYWORD "KILLVAR");
+      ("JUMP", KEYWORD T.Jump);
+      ("KILLALL", KEYWORD T.KillAll);
+      ("KILLOBJ", KEYWORD T.KillObj);
+      ("KILLQST", KEYWORD T.FreeLib);
+      ("KILLVAR", KEYWORD T.KillVar);
       ("LCASE", FUNCTION T.Lcase);
       ("$LCASE", FUNCTION T.Lcase')
       (*
@@ -99,19 +99,19 @@ let _ =
       ("LET", LET);
       ("LOC", FUNCTION T.Loc);
       ("MAINTXT", IDENT "MAINTXT");
-      ("$MAINTXT", IDENT "MAINTXT");
+      ("$MAINTXT", IDENT "$MAINTXT");
       ("MAX", FUNCTION T.Max);
       ("$MAX", FUNCTION T.Max');
-      ("MENU", KEYWORD "MENU");
+      ("MENU", KEYWORD T.Menu);
       ("MID", FUNCTION T.Mid);
       ("$MID", FUNCTION T.Mid');
       ("MIN", FUNCTION T.Min);
       ("$MIN", FUNCTION T.Min');
       ("MOD", MOD);
       ("MSECSCOUNT", FUNCTION T.Msecscount);
-      ("MSG", KEYWORD "MSG");
-      ("NL", KEYWORD "NL");
-      ("*NL", KEYWORD "*NL");
+      ("MSG", KEYWORD T.Msg);
+      ("NL", KEYWORD T.Nl);
+      ("*NL", KEYWORD T.Nl');
       ("NO", NO) (*
         ; "NOSAVE",           KEYWORD "NOSAVE"
 *);
@@ -123,33 +123,33 @@ let _ =
       ("$ONOBJADD", IDENT "$ONOBJADD");
       ("$ONOBJDEL", IDENT "$ONOBJDEL");
       ("$ONOBJSEL", IDENT "$ONOBJSEL");
-      ("OPENGAME", KEYWORD "OPENGAME");
-      ("OPENQST", KEYWORD "OPENQST");
+      ("OPENGAME", KEYWORD T.OpenGame);
+      ("OPENQST", KEYWORD T.OpenQst);
       ("OR", OR);
-      ("P", KEYWORD "P");
-      ("*P", KEYWORD "*P");
-      ("PL", KEYWORD "PL");
-      ("*PL", KEYWORD "*PL");
-      ("PLAY", KEYWORD "PLAY");
+      ("P", KEYWORD T.P);
+      ("*P", KEYWORD T.P');
+      ("PL", KEYWORD T.Pl);
+      ("*PL", KEYWORD T.Pl');
+      ("PLAY", KEYWORD T.Play);
       ("QSPVER", FUNCTION T.Qspver);
       ("$QSPVER", FUNCTION T.Qspver');
       ("RAND", FUNCTION T.Rand);
-      ("REFINT", KEYWORD "REFINT");
+      ("REFINT", KEYWORD T.RefInt);
       ("REPLACE", FUNCTION T.Replace);
       ("$REPLACE", FUNCTION T.Replace');
       ("RGB", FUNCTION T.Rgb);
       ("RND", FUNCTION T.Rnd);
-      ("SAVEGAME", KEYWORD "SAVEGAME");
+      ("SAVEGAME", KEYWORD T.SaveGame);
       ("SELACT", FUNCTION T.Selact);
       ("$SELACT", IDENT "$SELACT");
       ("SELOBJ", IDENT "SELOBJ");
       ("$SELOBJ", IDENT "$SELOBJ");
       ("SET", SET);
-      ("SETTIMER", KEYWORD "SETTIMER");
-      ("SHOWACTS", KEYWORD "SHOWACTS");
-      ("SHOWINPUT", KEYWORD "SHOWINPUT");
-      ("SHOWOBJS", KEYWORD "SHOWOBJS");
-      ("SHOWSTAT", KEYWORD "SHOWSTAT");
+      ("SETTIMER", KEYWORD T.SetTimer);
+      ("SHOWACTS", KEYWORD T.ShowActs);
+      ("SHOWINPUT", KEYWORD T.ShowInput);
+      ("SHOWOBJS", KEYWORD T.ShowObjs);
+      ("SHOWSTAT", KEYWORD T.ShowStat);
       ("STATTXT", FUNCTION T.Stattxt);
       ("$STATTXT", FUNCTION T.Stattxt');
       ("STR", FUNCTION T.Str);
@@ -162,8 +162,8 @@ let _ =
       ("$TRIM", FUNCTION T.Trim');
       ("UCASE", FUNCTION T.Ucase);
       ("$UCASE", FUNCTION T.Ucase');
-      ("UNSEL", KEYWORD "UNSELECT");
-      ("UNSELECT", KEYWORD "UNSELECT");
+      ("UNSEL", KEYWORD T.Unselect);
+      ("UNSELECT", KEYWORD T.Unselect);
       ("USEHTML", IDENT "USEHTML");
       ("USERCOM", IDENT "USERCOM");
       ("$USERCOM", IDENT "$USERCOM");
@@ -172,8 +172,8 @@ let _ =
       ("USRTXT", IDENT "USER_TEXT");
       ("$USRTXT", IDENT "USER_TEXT");
       ("VAL", FUNCTION T.Val);
-      ("VIEW", KEYWORD "VIEW");
-      ("WAIT", KEYWORD "WAIT");
-      ("XGOTO", KEYWORD "XGOTO");
-      ("XGT", KEYWORD "XGOTO");
+      ("VIEW", KEYWORD T.View);
+      ("WAIT", KEYWORD T.Wait);
+      ("XGOTO", KEYWORD T.XGoto);
+      ("XGT", KEYWORD T.XGoto);
     ]
diff --git a/lib/qparser/lexbuf.ml b/lib/qparser/lexbuf.ml
index 8a3e41c..cd0add3 100644
--- a/lib/qparser/lexbuf.ml
+++ b/lib/qparser/lexbuf.ml
@@ -68,3 +68,4 @@ let decr_level : t -> unit =
 
 let reset_level : t -> unit = fun t -> t.expression_level <- 0
 let level : t -> int = fun t -> t.expression_level
+let rollback : t -> unit = fun t -> Sedlexing.rollback t.buffer
diff --git a/lib/qparser/lexbuf.mli b/lib/qparser/lexbuf.mli
index 41f07d1..97a4d65 100644
--- a/lib/qparser/lexbuf.mli
+++ b/lib/qparser/lexbuf.mli
@@ -23,3 +23,5 @@ val reset_level : t -> unit
 
 val level : t -> int
 (** Return the nested expression level *)
+
+val rollback : t -> unit
diff --git a/lib/qparser/lexer.ml b/lib/qparser/lexer.ml
index fe2b487..383d6a3 100644
--- a/lib/qparser/lexer.ml
+++ b/lib/qparser/lexer.ml
@@ -11,6 +11,10 @@ exception EOF
 (* Extract the location name from the pattern *)
 let location_name = Str.regexp {|.* \(.*\)|}
 
+(** Try to read the identifier and check if this is a function, a keyword, or
+    just a variable. 
+
+    See the tests [Syntax.Operator2] and [Syntax.Call Nl] for two cases. *)
 let build_ident buffer =
   let id = Lexbuf.content buffer |> String.uppercase_ascii in
   try
@@ -19,7 +23,14 @@ let build_ident buffer =
       match value with IF | ELIF -> Lexbuf.incr_level buffer | _ -> ()
     in
     value
-  with Not_found -> IDENT id
+  with Not_found ->
+    (* If the identifier does not match a keyword and start with [*], then
+        try it as a '*' operator. *)
+    if Char.equal '*' id.[0] then (
+      Lexbuf.rollback buffer;
+      let lexbuf = Lexbuf.buffer buffer in
+      match%sedlex lexbuf with '*' -> STAR | _ -> IDENT id)
+    else IDENT id
 
 let wait_balance : (Buffer.t -> Lexbuf.t -> 'a) -> Lexbuf.t -> 'a =
  fun rule lexbuf ->
@@ -37,7 +48,7 @@ let coma = [%sedlex.regexp? ',']
 let digit = [%sedlex.regexp? '0' .. '9']
 let letters = [%sedlex.regexp? 'a' .. 'z' | 'A' .. 'Z' | '_']
 let spaces = [%sedlex.regexp? Plus space]
-let ident = [%sedlex.regexp? ('$' | letters), Star (digit | letters)]
+let ident = [%sedlex.regexp? Opt ('$' | '*'), letters, Star (digit | letters)]
 let location_ident = [%sedlex.regexp? letters | digit]
 let location_prefix = [%sedlex.regexp? '!' | '$' | '#' | '^']
 let location = [%sedlex.regexp? Opt location_prefix, Plus location_ident]
@@ -104,7 +115,7 @@ let rec skip_comment buffer =
   | eol ->
       (* Ugly hack used in order to put the eol in the front of the next
          parsing. *)
-      Sedlexing.rollback lexbuf;
+      Lexbuf.rollback buffer;
       COMMENT
   | any -> skip_comment buffer
   | _ -> raise Not_found
diff --git a/lib/qparser/qsp_instruction.mly b/lib/qparser/qsp_instruction.mly
index 564e154..bc1ca37 100644
--- a/lib/qparser/qsp_instruction.mly
+++ b/lib/qparser/qsp_instruction.mly
@@ -53,7 +53,7 @@ single_instruction:
     }
 
 keyword:
-    | STAR k = KEYWORD { "*" ^ k }
+    (*| STAR k = KEYWORD { "*" ^ k }*)
     | k = KEYWORD  { k }
 
 let_assignation:
diff --git a/lib/qparser/tokens.mly b/lib/qparser/tokens.mly
index 9ac4b10..a87ce98 100644
--- a/lib/qparser/tokens.mly
+++ b/lib/qparser/tokens.mly
@@ -38,7 +38,7 @@
 %token OBJ
 %token LOC
 %token NO
-%token <string>KEYWORD
+%token <Qsp_syntax.T.keywords>KEYWORD
 %token <Qsp_syntax.T.function_>FUNCTION
 
 (* 
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index 3873eed..63fcd08 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -53,7 +53,7 @@ module type Instruction = sig
   type expression
   type variable
 
-  val call : pos -> string -> expression list -> repr
+  val call : pos -> T.keywords -> expression list -> repr
   (** Call for an instruction like [GT] or [*CLR] *)
 
   val location : pos -> string -> repr
diff --git a/lib/syntax/t.ml b/lib/syntax/t.ml
index e9a901d..bf31253 100644
--- a/lib/syntax/t.ml
+++ b/lib/syntax/t.ml
@@ -78,7 +78,7 @@ type function_ =
 [@@deriving eq, show]
 
 type keywords =
-  | Inclib
+  | IncLib
   | Addobj
   | Cla
   | Clear
@@ -88,10 +88,6 @@ type keywords =
   | Cls
   | CmdClear
   | CopyArr
-  | CurActs
-  | CurActs'
-  | CurLoc
-  | CurLoc'
   | DelAct
   | FreeLib
   | DelObj
@@ -100,7 +96,6 @@ type keywords =
   | Exit
   | Gosub
   | Goto
-  | IncLib
   | Jump
   | KillAll
   | KillObj
@@ -113,23 +108,20 @@ type keywords =
   | Nl'
   | P
   | P'
+  | Pl
+  | Pl'
   | Play
-  | Play'
+  | OpenGame
+  | OpenQst
   | RefInt
   | SaveGame
-  | SelAct'
-  | SelObj
-  | SelObj'
   | SetTimer
   | ShowActs
   | ShowInput
   | ShowObjs
   | ShowStat
   | Unselect
-  | UseHTML
-  | UserCom'
-  | UserText
-  | UserText'
   | View
   | Wait
   | XGoto
+[@@deriving eq, show]
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index bb31253..ecad1b4 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -28,7 +28,7 @@ module Ast = struct
     | Declaration of ('a * 'a variable * T.assignation_operator * 'a expression)
     | Expression of 'a expression
     | Comment of 'a
-    | Call of 'a * string * 'a expression list
+    | Call of 'a * T.keywords * 'a expression list
     | Location of 'a * string
   [@@deriving eq, show]
 end
@@ -64,7 +64,7 @@ module Instruction :
   type expression = Expression.repr
   type variable = Expression.variable
 
-  let call : pos -> string -> expression list -> repr =
+  let call : pos -> T.keywords -> expression list -> repr =
    fun pos name args -> Ast.Call (pos, name, args)
 
   let location : pos -> string -> repr =
diff --git a/lib/syntax/tree.mli b/lib/syntax/tree.mli
index ca5a639..ad052e9 100644
--- a/lib/syntax/tree.mli
+++ b/lib/syntax/tree.mli
@@ -37,7 +37,7 @@ module Ast : sig
     | Declaration of ('a * 'a variable * T.assignation_operator * 'a expression)
     | Expression of 'a expression
     | Comment of 'a
-    | Call of 'a * string * 'a expression list
+    | Call of 'a * T.keywords * 'a expression list
     | Location of 'a * string
   [@@deriving eq, show]
 end
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index d578700..462f1cd 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -310,7 +310,7 @@ module Instruction = struct
   type variable = Expression.variable
 
   (** Call for an instruction like [GT] or [*CLR] *)
-  let call : pos -> string -> expression list -> repr =
+  let call : pos -> T.keywords -> expression list -> repr =
    fun _pos _ expressions report ->
     List.fold_left expressions ~init:report ~f:(fun report expression ->
         let result = expression report in