Merge with WebAssembly/spec

interpreter/dune

@@ -6,7 +6,8 @@
  ; Wasm REPL every time in all the dependencies.
  ; We exclude the 'wast' module as it is only used for the JS build.
  ; 'smallint' is a separate test module.
- (modules :standard \ main wasm smallint wast))
+ (modules :standard \ main wasm smallint wast)
+ (libraries menhirLib))
 
 (executable
  (public_name wasm)
@@ -43,7 +44,7 @@
    (chdir
     %{workspace_root}
     (run %{bin:ocamllex} -ml -q -o %{target} %{deps}))))
- (ocamlyacc
+ (menhir
   (modules parser)))
 
 (env

interpreter/dune-project

@@ -3,6 +3,8 @@
 (name wasm)
 
 (generate_opam_files true)
+(using menhir 2.1)
+(implicit_transitive_deps false)
 
 (license Apache-2.0)
 
@@ -17,4 +19,5 @@
   (synopsis "Library to read and write WebAssembly (Wasm) files and manipulate their AST")
   (tags (wasm webassembly spec interpreter))
   (depends
-    (ocaml (>= 4.12))))
+    (ocaml (>= 4.12))
+    (menhir (>= 20220210))))

interpreter/jslib/wast.ml

@@ -4,12 +4,12 @@
 open Wasm
 open Js_of_ocaml
 
-let _ =
+let () =
   Js.export "WebAssemblyText"
     (object%js (_self)
 
       method encode (s : Js.js_string Js.t) : (Typed_array.arrayBuffer Js.t) =
-        let def = Parse.string_to_definition (Js.to_string s) in
+        let _, def = Parse.Module.parse_string (Js.to_string s) in
         let bs =
           match def.Source.it with
           | Script.Textual m -> Encode.encode m

interpreter/script/js.ml

@@ -545,7 +545,8 @@ let rec of_definition def =
   | Textual m -> of_bytes (Encode.encode m)
   | Encoded (_, bs) -> of_bytes bs
   | Quoted (_, s) ->
-    try of_definition (Parse.string_to_definition s) with Parse.Syntax _ ->
+    try of_definition (snd (Parse.Module.parse_string s))
+    with Parse.Syntax _ ->
       of_bytes "<malformed quote>"
 
 let of_wrapper mods x_opt name wrap_action wrap_assertion at =
@@ -620,7 +621,7 @@ let of_command mods cmd =
       match def.it with
       | Textual m -> m
       | Encoded (_, bs) -> Decode.decode "binary" bs
-      | Quoted (_, s) -> unquote (Parse.string_to_definition s)
+      | Quoted (_, s) -> unquote (snd (Parse.Module.parse_string s))
     in bind mods x_opt (unquote def);
     "let " ^ current_var mods ^ " = instance(" ^ of_definition def ^ ");\n" ^
     (if x_opt = None then "" else

interpreter/script/run.ml

@@ -119,17 +119,20 @@ let input_from get_script run =
   | Assert (at, msg) -> error at "assertion failure" msg
   | Abort _ -> false
 
-let input_script start name lexbuf run =
-  input_from (fun _ -> Parse.parse name lexbuf start) run
+let input_script name lexbuf run =
+  input_from (fun () -> Parse.Script.parse name lexbuf) run
+
+let input_script1 name lexbuf run =
+  input_from (fun () -> Parse.Script1.parse name lexbuf) run
 
 let input_sexpr name lexbuf run =
-  input_from (fun _ ->
-    let var_opt, def = Parse.parse name lexbuf Parse.Module in
+  input_from (fun () ->
+    let var_opt, def = Parse.Module.parse name lexbuf in
     [Module (var_opt, def) @@ no_region]) run
 
 let input_binary name buf run =
   let open Source in
-  input_from (fun _ ->
+  input_from (fun () ->
     [Module (None, Encoded (name, buf) @@ no_region) @@ no_region]) run
 
 let input_sexpr_file input file run =
@@ -163,16 +166,16 @@ let input_file file run =
   dispatch_file_ext
     input_binary_file
     (input_sexpr_file input_sexpr)
-    (input_sexpr_file (input_script Parse.Script))
-    (input_sexpr_file (input_script Parse.Script))
+    (input_sexpr_file input_script)
+    (input_sexpr_file input_script)
     input_js_file
     file run
 
 let input_string string run =
   trace ("Running (\"" ^ String.escaped string ^ "\")...");
   let lexbuf = Lexing.from_string string in
   trace "Parsing...";
-  input_script Parse.Script "string" lexbuf run
+  input_script "string" lexbuf run
 
 
 (* Interactive *)
@@ -196,7 +199,7 @@ let lexbuf_stdin buf len =
 let input_stdin run =
   let lexbuf = Lexing.from_function lexbuf_stdin in
   let rec loop () =
-    let success = input_script Parse.Script1 "stdin" lexbuf run in
+    let success = input_script1 "stdin" lexbuf run in
     if not success then Lexing.flush_input lexbuf;
     if Lexing.(lexbuf.lex_curr_pos >= lexbuf.lex_buffer_len - 1) then
       continuing := false;
@@ -316,7 +319,7 @@ let rec run_definition def : Ast.module_ =
     Decode.decode name bs
   | Quoted (_, s) ->
     trace "Parsing quote...";
-    let def' = Parse.string_to_definition s in
+    let _, def' = Parse.Module.parse_string s in
     run_definition def'
 
 let run_action act : Value.t list =

interpreter/script/script.ml

@@ -66,8 +66,6 @@ and meta' =
 
 and script = command list
 
-exception Syntax of Source.region * string
-
 
 let () =
   let type_of_ref' = !Value.type_of_ref' in

interpreter/text/arrange.ml

@@ -803,14 +803,14 @@ let definition mode x_opt def =
         match def.it with
         | Textual m -> m
         | Encoded (_, bs) -> Decode.decode "" bs
-        | Quoted (_, s) -> unquote (Parse.string_to_definition s)
+        | Quoted (_, s) -> unquote (snd (Parse.Module.parse_string s))
       in module_with_var_opt x_opt (unquote def)
     | `Binary ->
       let rec unquote def =
         match def.it with
         | Textual m -> Encode.encode m
         | Encoded (_, bs) -> Encode.encode (Decode.decode "" bs)
-        | Quoted (_, s) -> unquote (Parse.string_to_definition s)
+        | Quoted (_, s) -> unquote (snd (Parse.Module.parse_string s))
       in binary_module_with_var_opt x_opt (unquote def)
     | `Original ->
       match def.it with

interpreter/text/lexer.mll

@@ -14,7 +14,7 @@ let region lexbuf =
   let right = convert_pos (Lexing.lexeme_end_p lexbuf) in
   {left = left; right = right}
 
-let error lexbuf msg = raise (Script.Syntax (region lexbuf, msg))
+let error lexbuf msg = raise (Parse_error.Syntax (region lexbuf, msg))
 let error_nest start lexbuf msg =
   lexbuf.Lexing.lex_start_p <- start;
   error lexbuf msg

interpreter/text/parse.ml

@@ -1,32 +1,52 @@
-type 'a start =
-  | Module : (Script.var option * Script.definition) start
-  | Script : Script.script start
-  | Script1 : Script.script start
-
-exception Syntax = Script.Syntax
-
-let parse' name lexbuf start =
-  lexbuf.Lexing.lex_curr_p <-
-    {lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = name};
-  try start Lexer.token lexbuf
-  with Syntax (region, s) ->
-    let region' = if region <> Source.no_region then region else
-      {Source.left = Lexer.convert_pos lexbuf.Lexing.lex_start_p;
-       Source.right = Lexer.convert_pos lexbuf.Lexing.lex_curr_p} in
-    raise (Syntax (region', s))
-
-let parse (type a) name lexbuf : a start -> a = function
-  | Module -> parse' name lexbuf Parser.module1
-  | Script -> parse' name lexbuf Parser.script
-  | Script1 -> parse' name lexbuf Parser.script1
-
-let string_to start s =
-  let lexbuf = Lexing.from_string s in
-  parse "string" lexbuf start
-
-let string_to_script s = string_to Script s
-let string_to_definition s = snd (string_to Module s)
-let string_to_module s =
-  match (string_to_definition s).Source.it with
-  | Script.Textual m -> m
-  | _ -> assert false
+exception Syntax = Parse_error.Syntax
+
+module type S =
+sig
+  type t
+  val parse : string -> Lexing.lexbuf -> t
+  val parse_file : string -> t
+  val parse_string : string -> t
+  val parse_channel : in_channel -> t
+end
+
+let provider buf () =
+  let tok = Lexer.token buf in
+  let start = Lexing.lexeme_start_p buf in
+  let stop = Lexing.lexeme_end_p buf in
+  tok, start, stop
+
+let convert_pos buf =
+  { Source.left = Lexer.convert_pos buf.Lexing.lex_start_p;
+    Source.right = Lexer.convert_pos buf.Lexing.lex_curr_p
+  }
+
+let make (type a) (start : _ -> _ -> a) : (module S with type t = a) =
+  (module struct
+    type t = a
+
+    let parse name buf =
+      Lexing.set_filename buf name;
+      try
+        MenhirLib.Convert.Simplified.traditional2revised start (provider buf)
+      with
+      | Parser.Error ->
+        raise (Syntax (convert_pos buf, "unexpected token"))
+      | Syntax (region, s) when region <> Source.no_region ->
+        raise (Syntax (convert_pos buf, s))
+
+    let parse_string s =
+      parse "string" (Lexing.from_string ~with_positions:true s)
+
+    let parse_channel oc =
+      parse "channel" (Lexing.from_channel ~with_positions:true oc)
+
+    let parse_file name =
+      let oc = open_in name in
+      Fun.protect ~finally:(fun () -> close_in oc) (fun () ->
+        parse name (Lexing.from_channel ~with_positions:true oc)
+      )
+  end)
+
+module Module = (val make Parser.module1)
+module Script = (val make Parser.script)
+module Script1 = (val make Parser.script1)

interpreter/text/parse.mli

@@ -1,12 +1,14 @@
-type 'a start =
-  | Module : (Script.var option * Script.definition) start
-  | Script : Script.script start
-  | Script1 : Script.script start
-
 exception Syntax of Source.region * string
 
-val parse : string -> Lexing.lexbuf -> 'a start -> 'a (* raises Syntax *)
+module type S =
+sig
+  type t
+  val parse : string -> Lexing.lexbuf -> t
+  val parse_file : string -> t
+  val parse_string : string -> t
+  val parse_channel : in_channel -> t
+end
 
-val string_to_script : string -> Script.script (* raises Syntax *)
-val string_to_definition : string -> Script.definition (* raises Syntax *)
-val string_to_module : string -> Ast.module_ (* raises Syntax *)
+module Module : S with type t = Script.var option * Script.definition
+module Script1 : S with type t = Script.script
+module Script : S with type t = Script.script

interpreter/text/parse_error.ml

@@ -0,0 +1,3 @@
+(* This is here since both Lexer, Parser, and Parse need it,
+ * but menhir cannot create a Parser that exports it. *)
+exception Syntax of Source.region * string