Script support for testing dynamic linking

ml-proto/README.md

@@ -183,8 +183,8 @@ exkind:  ( func <var> )
          ( table <var> )
          ( memory <var> )
 
-module:  ( module <typedef>* <func>* <import>* <export>* <table>? <memory>? <elem>* <data>* <start>? )
-         ( module <string>+ )
+module:  ( module <name>? <typedef>* <func>* <import>* <export>* <table>? <memory>? <elem>* <data>* <start>? )
+         ( module <name>? <string>+ )
 ```
 
 Here, productions marked with respective comments are abbreviation forms for equivalent expansions (see the explanation of the kernel AST below).
@@ -215,17 +215,25 @@ In order to be able to check and run modules for testing purposes, the S-express
 script: <cmd>*
 
 cmd:
-  <module>                                             ;; define, validate, and initialize module
-  ( invoke <name> <expr>* )                            ;; invoke export and print result
-  ( assert_return (invoke <name> <expr>* ) <expr> )    ;; assert return with expected result of invocation
-  ( assert_return_nan (invoke <name> <expr>* ))        ;; assert return with floating point nan result of invocation
-  ( assert_trap (invoke <name> <expr>* ) <failure> )   ;; assert invocation traps with given failure string
-  ( assert_invalid <module> <failure> )                ;; assert invalid module with given failure string
-  ( input <string> )                                   ;; read script or module from file
-  ( output <string>? )                                 ;; output module to stout or file
+  <module>                                  ;; define, validate, and initialize module
+  <action>                                  ;; perform action and print results
+  ( register <string> <name>? )             ;; register module for imports
+  ( assert_return <action> <expr>? )        ;; assert action has expected results
+  ( assert_return_nan <action> )            ;; assert action results in NaN
+  ( assert_trap <action> <failure> )        ;; assert action traps with given failure string
+  ( assert_invalid <module> <failure> )     ;; assert module is invalid with given failure string
+  ( assert_unlinkable <module> <failure> )  ;; assert module fails to link module with given failure string
+  ( input <string> )                        ;; read script or module from file
+  ( output <name>? <string>? )              ;; output module to stout or file
+
+action:
+  ( invoke <name>? <string> <expr>* )       ;; invoke function export
+  ( get <name>? <string> )                  ;; get global export
 ```
 
-Commands are executed in sequence. Invocation, assertions, and output apply to the most recently defined module (the _current_ module), and are only possible after a module has been defined. Note that there only ever is one current module, the different module definitions cannot interact.
+Commands are executed in sequence. Commands taking an optional module name refer to the most recently defined module if no name is given. They are only possible after a module has been defined.
+
+After a module is _registered_ under a string name it is available for importing in other modules.
 
 The input and output commands determine the requested file format from the file name extension. They can handle both `.wast` and `.wasm` files. In the case of input, a `.wast` script will be recursively executed.
 

ml-proto/given/lib.ml

@@ -1,3 +1,9 @@
+module Fun =
+struct
+  let rec repeat n f x =
+    if n = 0 then () else (f x; repeat (n - 1) f x)
+end
+
 module List =
 struct
   let rec make n x =

ml-proto/given/lib.mli

@@ -1,5 +1,10 @@
 (* Things that should be in the OCaml library... *)
 
+module Fun :
+sig
+  val repeat : int -> ('a -> unit) -> 'a -> unit
+end
+
 module List :
 sig
   val make : int -> 'a -> 'a list

ml-proto/host/import.mli

@@ -2,4 +2,7 @@ exception Unknown of Source.region * string
 
 val link : Kernel.module_ -> Instance.extern list (* raises Unknown *)
 
-val register : string -> (string -> Types.external_type -> Instance.extern) -> unit
+val register :
+  string ->
+  (string -> Types.external_type -> Instance.extern (* raise Not_found *)) ->
+  unit

ml-proto/host/lexer.mll

@@ -371,12 +371,14 @@ rule token = parse
   | "import" { IMPORT }
   | "export" { EXPORT }
 
+  | "register" { REGISTER }
+  | "invoke" { INVOKE }
+  | "get" { GET }
   | "assert_invalid" { ASSERT_INVALID }
   | "assert_unlinkable" { ASSERT_UNLINKABLE }
   | "assert_return" { ASSERT_RETURN }
   | "assert_return_nan" { ASSERT_RETURN_NAN }
   | "assert_trap" { ASSERT_TRAP }
-  | "invoke" { INVOKE }
   | "input" { INPUT }
   | "output" { OUTPUT }
 

ml-proto/host/parser.mly

@@ -63,15 +63,15 @@ type types = {mutable tmap : int VarMap.t; mutable tlist : Types.func_type list}
 let empty_types () = {tmap = VarMap.empty; tlist = []}
 
 type context =
-  {types : types; tables : space; memories : space; funcs : space;
-   locals : space; globals : space; labels : int VarMap.t}
+  { types : types; tables : space; memories : space;
+    funcs : space; locals : space; globals : space; labels : int VarMap.t }
 
 let empty_context () =
-  {types = empty_types (); tables = empty (); memories = empty ();
-   funcs = empty (); locals = empty (); globals = empty (); labels = VarMap.empty}
+  { types = empty_types (); tables = empty (); memories = empty ();
+    funcs = empty (); locals = empty (); globals = empty ();
+    labels = VarMap.empty }
 
 let enter_func c =
-  assert (VarMap.is_empty c.labels);
   {c with labels = VarMap.empty; locals = empty ()}
 
 let type_ c x =
@@ -91,12 +91,18 @@ let label c x =
   try VarMap.find x.it c.labels
   with Not_found -> error x.at ("unknown label " ^ x.it)
 
+let bind_module () x = Some x
+let anon_module () = None
+
 let bind_type c x ty =
   if VarMap.mem x.it c.types.tmap then
     error x.at ("duplicate type " ^ x.it);
   c.types.tmap <- VarMap.add x.it (List.length c.types.tlist) c.types.tmap;
   c.types.tlist <- c.types.tlist @ [ty]
 
+let anon_type c ty =
+  c.types.tlist <- c.types.tlist @ [ty]
+
 let bind category space x =
   if VarMap.mem x.it space.map then
     error x.at ("duplicate " ^ category ^ " " ^ x.it);
@@ -111,9 +117,6 @@ let bind_memory c x = bind "memory" c.memories x
 let bind_label c x =
   {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)}
 
-let anon_type c ty =
-  c.types.tlist <- c.types.tlist @ [ty]
-
 let anon space n = space.count <- space.count + n
 
 let anon_func c = anon c.funcs 1
@@ -151,8 +154,9 @@ let inline_type c t at =
 %token UNREACHABLE CURRENT_MEMORY GROW_MEMORY
 %token FUNC START TYPE PARAM RESULT LOCAL GLOBAL
 %token MODULE TABLE ELEM MEMORY DATA IMPORT EXPORT TABLE
+%token REGISTER INVOKE GET
 %token ASSERT_INVALID ASSERT_UNLINKABLE
-%token ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP INVOKE
+%token ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP
 %token INPUT OUTPUT
 %token EOF
 
@@ -597,28 +601,39 @@ module_fields :
       {m with exports = $1 c :: m.exports} }
 ;
 module_ :
-  | LPAR MODULE module_fields RPAR
-    { Textual ($3 (empty_context ()) @@ at ()) @@ at() }
-  | LPAR MODULE TEXT text_list RPAR { Binary ($3 ^ $4) @@ at() }
+  | LPAR MODULE module_var_opt module_fields RPAR
+    { $3, Textual ($4 (empty_context ()) @@ at ()) @@ at () }
+  | LPAR MODULE module_var_opt TEXT text_list RPAR
+    { $3, Binary ($4 ^ $5) @@ at() }
 ;
 
 
 /* Scripts */
 
+module_var_opt :
+  | /* empty */ { None }
+  | VAR { Some ($1 @@ at ()) }  /* Sugar */
+;
+action :
+  | LPAR INVOKE module_var_opt TEXT const_list RPAR
+    { Invoke ($3, $4, $5) @@ at () }
+  | LPAR GET module_var_opt TEXT RPAR
+    { Get ($3, $4) @@ at() }
+;
 cmd :
-  | module_ { Define $1 @@ at () }
-  | LPAR INVOKE TEXT const_list RPAR { Invoke ($3, $4) @@ at () }
-  | LPAR ASSERT_INVALID module_ TEXT RPAR { AssertInvalid ($3, $4) @@ at () }
-  | LPAR ASSERT_UNLINKABLE module_ TEXT RPAR { AssertUnlinkable ($3, $4) @@ at () }
-  | LPAR ASSERT_RETURN LPAR INVOKE TEXT const_list RPAR const_opt RPAR
-    { AssertReturn ($5, $6, $8) @@ at () }
-  | LPAR ASSERT_RETURN_NAN LPAR INVOKE TEXT const_list RPAR RPAR
-    { AssertReturnNaN ($5, $6) @@ at () }
-  | LPAR ASSERT_TRAP LPAR INVOKE TEXT const_list RPAR TEXT RPAR
-    { AssertTrap ($5, $6, $8) @@ at () }
+  | module_ { Define (fst $1, snd $1) @@ at () }
+  | action { Action $1 @@ at () }
+  | LPAR REGISTER TEXT module_var_opt RPAR { Register ($3, $4) @@ at () }
+  | LPAR ASSERT_INVALID module_ TEXT RPAR
+    { AssertInvalid (snd $3, $4) @@ at () }
+  | LPAR ASSERT_UNLINKABLE module_ TEXT RPAR
+    { AssertUnlinkable (snd $3, $4) @@ at () }
+  | LPAR ASSERT_RETURN action const_opt RPAR { AssertReturn ($3, $4) @@ at () }
+  | LPAR ASSERT_RETURN_NAN action RPAR { AssertReturnNaN $3 @@ at () }
+  | LPAR ASSERT_TRAP action TEXT RPAR { AssertTrap ($3, $4) @@ at () }
   | LPAR INPUT TEXT RPAR { Input $3 @@ at () }
-  | LPAR OUTPUT TEXT RPAR { Output (Some $3) @@ at () }
-  | LPAR OUTPUT RPAR { Output None @@ at () }
+  | LPAR OUTPUT module_var_opt TEXT RPAR { Output ($3, Some $4) @@ at () }
+  | LPAR OUTPUT module_var_opt RPAR { Output ($3, None) @@ at () }
 ;
 cmd_list :
   | /* empty */ { [] }
@@ -644,6 +659,6 @@ script1 :
   | cmd { [$1] }
 ;
 module1 :
-  | module_ EOF { $1 }
+  | module_ EOF { snd $1 }
 ;
 %%

ml-proto/host/run.ml

@@ -45,7 +45,7 @@ let run_binary name buf =
   run_from
     (fun _ ->
       let m = Decode.decode name buf in
-      [Script.Define (Script.Textual m @@ m.at) @@ m.at])
+      [Script.Define (None, Script.Textual m @@ m.at) @@ m.at])
 
 let run_sexpr_file file =
   Script.trace ("Loading (" ^ file ^ ")...");