[interpreter] Support quoted module definitions in .wast

interpreter/Makefile

@@ -10,8 +10,8 @@
 # Configuration
 
 NAME =		wasm
-UNOPT = 	$(NAME)
-OPT =   	$(NAME).opt
+UNOPT = 	$(NAME).debug
+OPT =   	$(NAME)
 LIB =		$(NAME)
 ZIP =		$(NAME).zip
 JSLIB =		wast.js

interpreter/host/js.ml

@@ -310,12 +310,13 @@ let of_literal lit =
   | Values.F32 z -> of_float (F32.to_float z)
   | Values.F64 z -> of_float (F64.to_float z)
 
-let of_definition def =
-  let bs =
-    match def.it with
-    | Textual m -> Encode.encode m
-    | Encoded (_, bs) -> bs
-  in of_bytes bs
+let rec of_definition def =
+  match def.it with
+  | Textual m -> of_bytes (Encode.encode m)
+  | Encoded (_, bs) -> of_bytes bs
+  | Quoted (_, s) ->
+    try of_definition (Parse.string_to_module s) with Parse.Syntax _ ->
+      of_bytes "<malformed quote>"
 
 let of_wrapper mods x_opt name wrap_action wrap_assertion at =
   let x = of_var_opt mods x_opt in
@@ -382,11 +383,12 @@ let of_command mods cmd =
     ":" ^ string_of_int cmd.at.left.line ^ "\n" ^
   match cmd.it with
   | Module (x_opt, def) ->
-    let m =
+    let rec unquote def =
       match def.it with
       | Textual m -> m
       | Encoded (_, bs) -> Decode.decode "binary" bs
-    in bind mods x_opt m;
+      | Quoted (_, s) -> unquote (Parse.string_to_module s)
+    in bind mods x_opt (unquote def);
     "let " ^ current_var mods ^ " = instance(" ^ of_definition def ^ ");\n" ^
     (if x_opt = None then "" else
     "let " ^ of_var_opt mods x_opt ^ " = " ^ current_var mods ^ ";\n")

interpreter/host/run.ml

@@ -281,12 +281,16 @@ let lookup_registry module_name item_name _t =
 
 (* Running *)
 
-let run_definition def =
+let rec run_definition def =
   match def.it with
   | Textual m -> m
   | Encoded (name, bs) ->
     trace "Decoding...";
     Decode.decode name bs
+  | Quoted (_, s) ->
+    trace "Parsing quote...";
+    let def' = Parse.string_to_module s in
+    run_definition def'
 
 let run_action act =
   match act.it with
@@ -332,7 +336,8 @@ let run_assertion ass =
     trace "Asserting malformed...";
     (match ignore (run_definition def) with
     | exception Decode.Code (_, msg) -> assert_message ass.at "decoding" msg re
-    | _ -> Assert.error ass.at "expected decoding error"
+    | exception Parse.Syntax (_, msg) -> assert_message ass.at "parsing" msg re
+    | _ -> Assert.error ass.at "expected decoding/parsing error"
     )
 
   | AssertInvalid (def, re) ->

interpreter/text/arrange.ml

@@ -12,18 +12,17 @@ let nat n = I32.to_string_u (I32.of_int_u n)
 let nat32 = I32.to_string_u
 
 let add_hex_char buf c = Printf.bprintf buf "\\%02x" (Char.code c)
-let add_char buf c =
-  if c < '\x20' || c >= '\x7f' then
-    add_hex_char buf c
-  else begin
-    if c = '\"' || c = '\\' then Buffer.add_char buf '\\';
-    Buffer.add_char buf c
-  end
-let add_unicode_char buf uc =
-  if uc < 0x20 || uc >= 0x7f then
-    Printf.bprintf buf "\\u{%02x}" uc
-  else
-    add_char buf (Char.chr uc)
+let add_char buf = function
+  | '\n' -> Buffer.add_string buf "\\n"
+  | '\t' -> Buffer.add_string buf "\\t"
+  | '\"' -> Buffer.add_string buf "\\\""
+  | '\\' -> Buffer.add_string buf "\\\\"
+  | c when '\x20' <= c && c < '\x7f' -> Buffer.add_char buf c
+  | c -> add_hex_char buf c
+let add_unicode_char buf = function
+  | (0x09 | 0x0a) as uc -> add_char buf (Char.chr uc)
+  | uc when 0x20 <= uc && uc < 0x7f -> add_char buf (Char.chr uc)
+  | uc -> Printf.bprintf buf "\\u{%02x}" uc
 
 let string_with iter add_char s =
   let buf = Buffer.create 256 in
@@ -49,6 +48,10 @@ let break_bytes s =
   let ss = Lib.String.breakup s 16 in
   list (atom bytes) ss
 
+let break_string s =
+  let ss, s' = Lib.List.split_last (Lib.String.split s '\n') in
+  list (atom string) (List.map (fun s -> s ^ "\n") ss @ [s'])
+
 
 (* Types *)
 
@@ -369,7 +372,10 @@ let module_with_var_opt x_opt m =
   )
 
 let binary_module_with_var_opt x_opt bs =
-  Node ("module" ^ var_opt x_opt, break_bytes bs)
+  Node ("module" ^ var_opt x_opt ^ " binary", break_bytes bs)
+
+let quoted_module_with_var_opt x_opt s =
+  Node ("module" ^ var_opt x_opt ^ " quote", break_string s)
 
 let module_ = module_with_var_opt None
 
@@ -384,19 +390,26 @@ let literal lit =
   | Values.F64 z -> Node ("f64.const " ^ F64.to_string z, [])
 
 let definition mode x_opt def =
-  match mode, def.it with
-  | `Textual, _ | `Original, Textual _ ->
-    let m =
-      match def.it with
-      | Textual m -> m
-      | Encoded (_, bs) -> Decode.decode "" bs
-    in module_with_var_opt x_opt m
-  | `Binary, _ | `Original, Encoded _ ->
-    let bs =
-      match def.it with
-      | Textual m -> Encode.encode m
-      | Encoded (_, bs) -> bs
-    in binary_module_with_var_opt x_opt bs
+  try
+    match mode, def.it with
+    | `Textual, _ | `Original, Textual _ ->
+      let rec unquote def =
+        match def.it with
+        | Textual m -> m
+        | Encoded (_, bs) -> Decode.decode "" bs
+        | Quoted (_, s) -> unquote (Parse.string_to_module s)
+      in module_with_var_opt x_opt (unquote def)
+    | `Binary, _ | `Original, Encoded _ ->
+      let rec unquote bs =
+        match def.it with
+        | Textual m -> Encode.encode m
+        | Encoded (_, bs) -> bs
+        | Quoted (_, s) -> unquote (Parse.string_to_module s)
+      in binary_module_with_var_opt x_opt (unquote def)
+    | `Original, Quoted (_, s) ->
+      quoted_module_with_var_opt x_opt s
+  with Parse.Syntax _ ->
+    quoted_module_with_var_opt x_opt "<invalid module>"
 
 let access x_opt n =
   String.concat " " [var_opt x_opt; name n]

interpreter/text/lexer.mll

@@ -322,7 +322,6 @@ rule token = parse
   | "result" { RESULT }
   | "local" { LOCAL }
   | "global" { GLOBAL }
-  | "module" { MODULE }
   | "table" { TABLE }
   | "memory" { MEMORY }
   | "elem" { ELEM }
@@ -331,6 +330,10 @@ rule token = parse
   | "import" { IMPORT }
   | "export" { EXPORT }
 
+  | "module" { MODULE }
+  | "binary" { BIN }
+  | "quote" { QUOTE }
+
   | "script" { SCRIPT }
   | "register" { REGISTER }
   | "invoke" { INVOKE }

interpreter/text/parser.mly

@@ -160,10 +160,11 @@ let inline_type_explicit (c : context) x ty at =
 %token CALL CALL_INDIRECT RETURN
 %token GET_LOCAL SET_LOCAL TEE_LOCAL GET_GLOBAL SET_GLOBAL
 %token LOAD STORE OFFSET_EQ_NAT ALIGN_EQ_NAT
-%token CONST UNARY BINARY COMPARE CONVERT
+%token CONST UNARY BINARY TEST COMPARE CONVERT
 %token UNREACHABLE CURRENT_MEMORY GROW_MEMORY
 %token FUNC START TYPE PARAM RESULT LOCAL GLOBAL
-%token MODULE TABLE ELEM MEMORY DATA OFFSET IMPORT EXPORT TABLE
+%token TABLE ELEM MEMORY DATA OFFSET IMPORT EXPORT TABLE
+%token MODULE BIN QUOTE
 %token SCRIPT REGISTER INVOKE GET
 %token ASSERT_MALFORMED ASSERT_INVALID ASSERT_SOFT_INVALID ASSERT_UNLINKABLE
 %token ASSERT_RETURN ASSERT_RETURN_CANONICAL_NAN ASSERT_RETURN_ARITHMETIC_NAN ASSERT_TRAP ASSERT_EXHAUSTION
@@ -655,11 +656,13 @@ module_fields1 :
     { fun c -> let m = $2 c in
       {m with exports = $1 c :: m.exports} }
 
+module_var_opt :
+  | /* empty */ { None }
+  | VAR { Some ($1 @@ at ()) }  /* Sugar */
+
 module_ :
-  | LPAR MODULE script_var_opt module_fields RPAR
+  | LPAR MODULE module_var_opt module_fields RPAR
     { $3, Textual ($4 (empty_context ()) @@ at ()) @@ at () }
-  | LPAR MODULE script_var_opt STRING string_list RPAR
-    { $3, Encoded ("binary", $4 ^ $5) @@ at() }
 
 inline_module :  /* Sugar */
   | module_fields { Textual ($1 (empty_context ()) @@ at ()) @@ at () }
@@ -674,20 +677,27 @@ script_var_opt :
   | /* empty */ { None }
   | VAR { Some ($1 @@ at ()) }  /* Sugar */
 
+script_module :
+  | module_ { $1 }
+  | LPAR MODULE module_var_opt BIN string_list RPAR
+    { $3, Encoded ("binary", $5) @@ at() }
+  | LPAR MODULE module_var_opt QUOTE string_list RPAR
+    { $3, Quoted ("quote", $5) @@ at() }
+
 action :
-  | LPAR INVOKE script_var_opt name const_list RPAR
+  | LPAR INVOKE module_var_opt name const_list RPAR
     { Invoke ($3, $4, $5) @@ at () }
-  | LPAR GET script_var_opt name RPAR
+  | LPAR GET module_var_opt name RPAR
     { Get ($3, $4) @@ at() }
 
 assertion :
-  | LPAR ASSERT_MALFORMED module_ STRING RPAR
+  | LPAR ASSERT_MALFORMED script_module STRING RPAR
     { AssertMalformed (snd $3, $4) @@ at () }
-  | LPAR ASSERT_INVALID module_ STRING RPAR
+  | LPAR ASSERT_INVALID script_module STRING RPAR
     { AssertInvalid (snd $3, $4) @@ at () }
-  | LPAR ASSERT_UNLINKABLE module_ STRING RPAR
+  | LPAR ASSERT_UNLINKABLE script_module STRING RPAR
     { AssertUnlinkable (snd $3, $4) @@ at () }
-  | LPAR ASSERT_TRAP module_ STRING RPAR
+  | LPAR ASSERT_TRAP script_module STRING RPAR
     { AssertUninstantiable (snd $3, $4) @@ at () }
   | LPAR ASSERT_RETURN action const_list RPAR { AssertReturn ($3, $4) @@ at () }
   | LPAR ASSERT_RETURN_CANONICAL_NAN action RPAR { AssertReturnCanonicalNaN $3 @@ at () }
@@ -698,8 +708,8 @@ assertion :
 cmd :
   | action { Action $1 @@ at () }
   | assertion { Assertion $1 @@ at () }
-  | module_ { Module (fst $1, snd $1) @@ at () }
-  | LPAR REGISTER name script_var_opt RPAR { Register ($3, $4) @@ at () }
+  | script_module { Module (fst $1, snd $1) @@ at () }
+  | LPAR REGISTER name module_var_opt RPAR { Register ($3, $4) @@ at () }
   | meta { Meta $1 @@ at () }
 
 cmd_list :

interpreter/text/script.ml

@@ -4,6 +4,7 @@ type definition = definition' Source.phrase
 and definition' =
   | Textual of Ast.module_
   | Encoded of string * string
+  | Quoted of string * string
 
 type action = action' Source.phrase
 and action' =

interpreter/util/lib.ml

@@ -28,6 +28,14 @@ struct
     for i = String.length s - 1 downto 0 do cs := s.[i] :: !cs done;
     !cs
 
+  let split s c =
+    let len = String.length s in
+    let rec loop i =
+      if i > len then [] else
+      let j = try String.index_from s i c with Not_found -> len in
+      String.sub s i (j - i) :: loop (j + 1)
+    in loop 0
+
   let breakup s n =
     let rec loop i =
       let len = min n (String.length s - i) in

interpreter/util/lib.mli

@@ -66,5 +66,6 @@ module String :
 sig
   val implode : char list -> string
   val explode : string -> char list
+  val split : string -> char -> string list
   val breakup : string -> int -> string list
 end

test/core/address.wast

@@ -32,3 +32,11 @@
 (assert_trap (invoke "good" (i32.const 65508)) "out of bounds memory access")
 (assert_trap (invoke "bad" (i32.const 0)) "out of bounds memory access")
 (assert_trap (invoke "bad" (i32.const 1)) "out of bounds memory access")
+
+(assert_malformed
+  (module quote
+    "(memory 1)"
+    "(func (drop (i32.load offset=4294967296 (i32.const 0))))"
+  )
+  "i32 constant"
+)

test/core/align.wast

@@ -0,0 +1,33 @@
+(assert_malformed
+  (module quote
+    "(module (memory 0) (func (drop (i64.load align=0 (i32.const 0)))))"
+  )
+  "alignment"
+)
+(assert_malformed
+  (module quote
+    "(module (memory 0) (func (drop (i64.load align=7 (i32.const 0)))))"
+  )
+  "alignment"
+)
+(assert_invalid
+  (module (memory 0) (func (drop (i64.load align=16 (i32.const 0)))))
+  "alignment"
+)
+
+(assert_malformed
+  (module quote
+    "(module (memory 0) (func (i64.store align=0 (i32.const 0) (i64.const 0))))"
+  )
+  "alignment"
+)
+(assert_malformed
+  (module quote
+    "(module (memory 0) (func (i64.store align=5 (i32.const 0) (i64.const 0))))"
+  )
+  "alignment"
+)
+(assert_invalid
+  (module (memory 0) (func (i64.store align=16 (i32.const 0) (i64.const 0))))
+  "alignment"
+)