Vaidation returns module type

Author: rossberg

interpreter/script/import.ml

@@ -10,8 +10,8 @@ let registry = ref Registry.empty
 
 let register name lookup = registry := Registry.add name lookup !registry
 
-let lookup (ImportT (et, module_name, item_name)) at : Instance.extern =
-  try Registry.find module_name !registry item_name et with Not_found ->
+let lookup (ImportT (module_name, item_name, xt)) at : Instance.extern =
+  try Registry.find module_name !registry item_name xt with Not_found ->
     Unknown.error at
       ("unknown import \"" ^ Types.string_of_name module_name ^
         "\".\"" ^ Types.string_of_name item_name ^ "\"")

interpreter/script/js.ml

@@ -226,7 +226,7 @@ type env =
 
 let exports m : exports =
   let ModuleT (_, ets) = moduletype_of m in
-  List.fold_left (fun map (ExportT (et, name)) -> NameMap.add name et map)
+  List.fold_left (fun map (ExportT (name, xt)) -> NameMap.add name xt map)
     NameMap.empty ets
 
 let env () : env =
@@ -622,7 +622,7 @@ let wrap item_name wrap_action wrap_assertion at =
   let funcs = [Func (0l @@ at, locals, body) @@ at] in
   let m = {empty_module with types; funcs; imports; exports} @@ at in
   (try
-    Valid.check_module m;  (* sanity check *)
+    ignore (Valid.check_module m);  (* sanity check *)
   with Valid.Invalid _ as exn ->
     prerr_endline (string_of_region at ^
       ": internal error in JS converter, invalid wrapper module generated:");

interpreter/script/run.ml

@@ -220,10 +220,10 @@ let indent s =
   let lines = List.filter ((<>) "") (String.split_on_char '\n' s) in
   String.concat "\n" (List.map ((^) "  ") lines) ^ "\n"
 
-let print_module x_opt m =
+let print_moduletype x_opt mt =
   Printf.printf "module%s :\n%s%!"
     (match x_opt with None -> "" | Some x -> " " ^ x.it)
-    (indent (Types.string_of_moduletype (Ast.moduletype_of m)))
+    (indent (Types.string_of_moduletype mt))
 
 let print_values vs =
   let ts = List.map Value.type_of_value vs in
@@ -469,7 +469,7 @@ let run_assertion ass =
     trace "Asserting invalid...";
     (match
       let m, cs = run_definition def in
-      Valid.check_module_with_custom (m, cs)
+      ignore (Valid.check_module_with_custom (m, cs))
     with
     | exception Valid.Invalid (_, msg) ->
       assert_message ass.at "validation" msg re
@@ -480,7 +480,7 @@ let run_assertion ass =
     trace "Asserting invalid custom...";
     (match
       let m, cs = run_definition def in
-      Valid.check_module_with_custom (m, cs)
+      ignore (Valid.check_module_with_custom (m, cs))
     with
     | exception Custom.Invalid (_, msg) ->
       assert_message ass.at "custom validation" msg re
@@ -490,7 +490,7 @@ let run_assertion ass =
   | AssertUnlinkable (x_opt, re) ->
     trace "Asserting unlinkable...";
     let m, cs = lookup_module x_opt ass.at in
-    if not !Flags.unchecked then Valid.check_module_with_custom (m, cs);
+    if not !Flags.unchecked then ignore (Valid.check_module_with_custom (m, cs));
     (match
       let imports = Import.link m in
       ignore (Eval.init m imports)
@@ -503,7 +503,7 @@ let run_assertion ass =
   | AssertUninstantiable (x_opt, re) ->
     trace "Asserting trap...";
     let m, cs = lookup_module x_opt ass.at in
-    if not !Flags.unchecked then Valid.check_module_with_custom (m, cs);
+    if not !Flags.unchecked then ignore (Valid.check_module_with_custom (m, cs));
     (match
       let imports = Import.link m in
       ignore (Eval.init m imports)
@@ -547,10 +547,10 @@ let rec run_command cmd =
     let m, cs = run_definition def in
     if not !Flags.unchecked then begin
       trace "Checking...";
-      Valid.check_module_with_custom (m, cs);
+      let mt = Valid.check_module_with_custom (m, cs) in
       if !Flags.print_sig then begin
         trace "Signature:";
-        print_module x_opt m
+        print_moduletype x_opt mt
       end
     end;
     bind "module" modules x_opt (m, cs);

interpreter/syntax/ast.ml

@@ -345,8 +345,6 @@ and module_' =
 }
 
 
-(* Auxiliary functions *)
-
 let empty_module =
 {
   types = [];
@@ -362,6 +360,9 @@ let empty_module =
   exports = [];
 }
 
+
+(* Extract module type (unchecked) *)
+
 open Source
 
 let deftypes_of (m : module_) : deftype list =
@@ -374,7 +375,7 @@ let deftypes_of (m : module_) : deftype list =
 let importtype_of (m : module_) (im : import) : importtype =
   let Import (module_name, item_name, xt) = im.it in
   let dts = deftypes_of m in
-  ImportT (subst_externtype (subst_of dts) xt, module_name, item_name)
+  ImportT (module_name, item_name, subst_externtype (subst_of dts) xt)
 
 let exporttype_of (m : module_) (ex : export) : exporttype =
   let Export (name, xx) = ex.it in
@@ -403,7 +404,7 @@ let exporttype_of (m : module_) (ex : export) : exporttype =
       let tts = tags xts @ List.map (fun t ->
         let Tag tt = t.it in tt) m.it.tags in
       ExternTagT (Lib.List32.nth tts x.it)
-  in ExportT (subst_externtype (subst_of dts) xt, name)
+  in ExportT (name, subst_externtype (subst_of dts) xt)
 
 let moduletype_of (m : module_) : moduletype =
   let its = List.map (importtype_of m) m.it.imports in

interpreter/syntax/types.ml

@@ -57,8 +57,8 @@ type externtype =
   | ExternGlobalT of globaltype
   | ExternTagT of tagtype
 
-type exporttype = ExportT of externtype * name
-type importtype = ImportT of externtype * name * name
+type exporttype = ExportT of name * externtype
+type importtype = ImportT of name * name * externtype
 type moduletype = ModuleT of importtype list * exporttype list
 
 
@@ -135,8 +135,8 @@ let structtype_of_comptype = function StructCT st -> st | _ -> assert false
 let arraytype_of_comptype = function ArrayCT at -> at | _ -> assert false
 let functype_of_comptype = function FuncCT ft -> ft | _ -> assert false
 
-let externtype_of_importtype = function ImportT (et, _, _) -> et
-let externtype_of_exporttype = function ExportT (et, _) -> et
+let externtype_of_importtype = function ImportT (_, _, xt) -> xt
+let externtype_of_exporttype = function ExportT (_, xt) -> xt
 
 
 (* Filters *)
@@ -247,11 +247,11 @@ let subst_externtype s = function
 
 
 let subst_exporttype s = function
-  | ExportT (xt, name) -> ExportT (subst_externtype s xt, name)
+  | ExportT (name, xt) -> ExportT (name, subst_externtype s xt)
 
 let subst_importtype s = function
-  | ImportT (xt, module_name, name) ->
-    ImportT (subst_externtype s xt, module_name, name)
+  | ImportT (module_name, name, xt) ->
+    ImportT (module_name, name, subst_externtype s xt)
 
 let subst_moduletype s = function
   | ModuleT (its, ets) ->
@@ -447,11 +447,11 @@ let string_of_externtype = function
 
 
 let string_of_exporttype = function
-  | ExportT (xt, name) ->
+  | ExportT (name, xt) ->
     "\"" ^ string_of_name name ^ "\" : " ^ string_of_externtype xt
 
 let string_of_importtype = function
-  | ImportT (xt, module_name, name) ->
+  | ImportT (module_name, name, xt) ->
     "\"" ^ string_of_name module_name ^ "\" \"" ^
       string_of_name name ^ "\" : " ^ string_of_externtype xt
 

interpreter/valid/valid.ml

@@ -1125,23 +1125,30 @@ let check_import (c : context) (im : import) : context =
 
 module NameSet = Set.Make(struct type t = Ast.name let compare = compare end)
 
-let check_export (c : context) (set : NameSet.t) (ex : export) : NameSet.t =
+let check_export (c : context) (ex : export) : exporttype =
   let Export (name, xx) = ex.it in
-  (match xx.it with
-  | FuncX x -> ignore (func c x)
-  | GlobalX x -> ignore (global c x)
-  | TableX x -> ignore (table c x)
-  | MemoryX x -> ignore (memory c x)
-  | TagX x -> ignore (tag c x)
-  );
-  require (not (NameSet.mem name set)) ex.at "duplicate export name";
-  NameSet.add name set
-
+  let xt =
+    match xx.it with
+    | FuncX x -> ExternFuncT (Def (func c x))
+    | GlobalX x -> ExternGlobalT (global c x)
+    | TableX x -> ExternTableT (table c x)
+    | MemoryX x -> ExternMemoryT (memory c x)
+    | TagX x -> ExternTagT (tag c x)
+  in ExportT (name, xt)
 
 let check_list f xs (c : context) : context =
   List.fold_left f c xs
 
-let check_module (m : module_) =
+let check_names (names : name list) at =
+  ignore (
+    List.fold_left (fun set name ->
+      require (not (NameSet.mem name set)) at
+        ("duplicate export name \"" ^ string_of_name name ^ "\"");
+      NameSet.add name set
+    ) NameSet.empty names
+  )
+
+let check_module (m : module_) : moduletype =
   let refs = Free.module_ ({m.it with funcs = []; start = None} @@ m.at) in
   let c =
     {empty_context with refs}
@@ -1157,8 +1164,14 @@ let check_module (m : module_) =
   in
   List.iter (check_func_body c) m.it.funcs;
   Option.iter (check_start c) m.it.start;
-  ignore (List.fold_left (check_export c) NameSet.empty m.it.exports)
+  let its = List.map (fun {it = Import (mnm, nm, xt); _} -> ImportT (mnm, nm, xt)) m.it.imports in
+  let ets = List.map (check_export c) m.it.exports in
+  check_names (List.map (fun (ExportT (nm, _xt)) -> nm) ets) m.at;
+  subst_moduletype (subst_of c.types) (ModuleT (its, ets))
+
 
-let check_module_with_custom ((m : module_), (cs : Custom.section list)) =
-  check_module m;
-  List.iter (fun (module S : Custom.Section) -> S.Handler.check m S.it) cs
+let check_module_with_custom ((m : module_), (cs : Custom.section list))
+  : moduletype =
+  let mt = check_module m in
+  List.iter (fun (module S : Custom.Section) -> S.Handler.check m S.it) cs;
+  mt

interpreter/valid/valid.mli

@@ -1,4 +1,4 @@
 exception Invalid of Source.region * string
 
-val check_module : Ast.module_ -> unit (* raises Invalid *)
-val check_module_with_custom : Ast.module_ * Custom.section list -> unit (* raises Invalid, Custom.Check *)
+val check_module : Ast.module_ -> Types.moduletype (* raises Invalid *)
+val check_module_with_custom : Ast.module_ * Custom.section list -> Types.moduletype (* raises Invalid, Custom.Check *)