Represent all names in UTF-8

interpreter/host/import.ml

@@ -4,7 +4,7 @@ open Ast
 module Unknown = Error.Make ()
 exception Unknown = Unknown.Error  (* indicates unknown import name *)
 
-module Registry = Map.Make(String)
+module Registry = Instance.ExportMap
 let registry = ref Registry.empty
 
 let register name lookup = registry := Registry.add name lookup !registry
@@ -14,6 +14,7 @@ let lookup (m : module_) (im : import) : Instance.extern =
   let t = import_type m im in
   try Registry.find module_name !registry item_name t with Not_found ->
     Unknown.error im.at
-      ("unknown import \"" ^ module_name ^ "." ^ item_name ^ "\"")
+      ("unknown import \"" ^ String.escaped (Utf8.encode module_name) ^
+        "\".\"" ^ String.escaped (Utf8.encode item_name) ^ "\"")
 
 let link m = List.map (lookup m) m.it.imports

interpreter/host/import.mli

@@ -3,6 +3,6 @@ exception Unknown of Source.region * string
 val link : Ast.module_ -> Instance.extern list (* raises Unknown *)
 
 val register :
-  string ->
-  (string -> Types.external_type -> Instance.extern (* raise Not_found *)) ->
+  Ast.name ->
+  (Ast.name -> Types.external_type -> Instance.extern (* raise Not_found *)) ->
   unit

interpreter/host/import/env.ml

@@ -40,7 +40,7 @@ let exit vs =
 
 
 let lookup name t =
-  match name, t with
+  match Utf8.encode name, t with
   | "abort", ExternalFuncType t -> ExternalFunc (HostFunc (t, abort))
   | "exit", ExternalFuncType t -> ExternalFunc (HostFunc (t, exit))
   | _ -> raise Not_found

interpreter/host/import/spectest.ml

@@ -28,7 +28,7 @@ let print (FuncType (_, out)) vs =
 
 
 let lookup name t =
-  match name, t with
+  match Utf8.encode name, t with
   | "print", ExternalFuncType t -> ExternalFunc (HostFunc (t, print t))
   | "print", _ ->
     let t = FuncType ([], []) in ExternalFunc (HostFunc (t, print t))

interpreter/host/js.ml

@@ -139,14 +139,15 @@ let harness =
 (* Context *)
 
 module Map = Map.Make(String)
+module ExportMap = Instance.ExportMap
 
-type exports = external_type Map.t
+type exports = external_type ExportMap.t
 type modules = {mutable env : exports Map.t; mutable current : int}
 
 let exports m : exports =
   List.fold_left
-    (fun map exp -> Map.add exp.it.name (export_type m exp) map)
-    Map.empty m.it.exports
+    (fun map exp -> ExportMap.add exp.it.name (export_type m exp) map)
+    ExportMap.empty m.it.exports
 
 let modules () : modules = {env = Map.empty; current = 0}
 
@@ -167,8 +168,9 @@ let lookup (mods : modules) x_opt name at =
       raise (Eval.Crash (at, 
         if x_opt = None then "no module defined within script"
         else "unknown module " ^ of_var_opt mods x_opt ^ " within script"))
-  in try Map.find name exports with Not_found ->
-    raise (Eval.Crash (at, "unknown export \"" ^ name ^ "\" within module"))
+  in try ExportMap.find name exports with Not_found ->
+    raise (Eval.Crash (at, "unknown export \"" ^
+      String.escaped (Utf8.encode name) ^ "\" within module"))
 
 
 (* Wrappers *)
@@ -245,7 +247,7 @@ let wrap module_name item_name wrap_action wrap_assertion at =
   let types = FuncType ([], []) :: itypes in
   let imports = [{module_name; item_name; idesc} @@ at] in
   let edesc = FuncExport item @@ at in
-  let exports = [{name = "run"; edesc} @@ at] in
+  let exports = [{name = Utf8.decode "run"; edesc} @@ at] in
   let body =
     [ Block ([], action @ assertion @ [Return @@ at]) @@ at;
       Unreachable @@ at ]
@@ -286,6 +288,7 @@ let of_string_with add_char s =
 
 let of_bytes = of_string_with add_hex_char
 let of_string = of_string_with add_char
+let of_name n = of_string (Utf8.encode n)
 
 let of_float z =
   match string_of_float z with
@@ -311,14 +314,14 @@ let of_definition def =
 
 let of_wrapper mods x_opt name wrap_action wrap_assertion at =
   let x = of_var_opt mods x_opt in
-  let bs = wrap x name wrap_action wrap_assertion at in
+  let bs = wrap (Utf8.decode x) name wrap_action wrap_assertion at in
   "call(instance(" ^ of_bytes bs ^ ", " ^
     "exports(" ^ of_string x ^ ", " ^ x ^ ")), " ^ " \"run\", [])"
 
 let of_action mods act =
   match act.it with
   | Invoke (x_opt, name, lits) ->
-    "call(" ^ of_var_opt mods x_opt ^ ", " ^ of_string name ^ ", " ^
+    "call(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ", " ^
       "[" ^ String.concat ", " (List.map of_literal lits) ^ "])",
     (match lookup mods x_opt name act.at with
     | ExternalFuncType ft when not (is_js_func_type ft) ->
@@ -327,7 +330,7 @@ let of_action mods act =
     | _ -> None
     )
   | Get (x_opt, name) ->
-    "get(" ^ of_var_opt mods x_opt ^ ", " ^ of_string name ^ ")",
+    "get(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ")",
     (match lookup mods x_opt name act.at with
     | ExternalGlobalType gt when not (is_js_global_type gt) ->
       let GlobalType (t, _) = gt in
@@ -383,7 +386,7 @@ let of_command mods cmd =
     (if x_opt = None then "" else
     "let " ^ of_var_opt mods x_opt ^ " = " ^ current_var mods ^ ";\n")
   | Register (name, x_opt) ->
-    "register(" ^ of_string name ^ ", " ^ of_var_opt mods x_opt ^ ")\n"
+    "register(" ^ of_name name ^ ", " ^ of_var_opt mods x_opt ^ ")\n"
   | Action act ->
     of_assertion' mods act "run" [] None ^ "\n"
   | Assertion ass ->

interpreter/host/main.ml

@@ -2,8 +2,8 @@ let name = "wasm"
 let version = "0.7"
 
 let configure () =
-  Import.register "spectest" Spectest.lookup;
-  Import.register "env" Env.lookup
+  Import.register (Utf8.decode "spectest") Spectest.lookup;
+  Import.register (Utf8.decode "env") Env.lookup
 
 let banner () =
   print_endline

interpreter/host/run.ml

@@ -188,6 +188,8 @@ let input_stdin run =
 
 (* Printing *)
 
+let string_of_name n = String.escaped (Utf8.encode n)
+
 let print_import m im =
   let open Types in
   let category, annotation =
@@ -198,7 +200,8 @@ let print_import m im =
     | ExternalGlobalType t -> "global", string_of_global_type t
   in
   Printf.printf "  import %s %S %S : %s\n"
-    category im.it.Ast.module_name im.it.Ast.item_name annotation
+    category (string_of_name im.it.Ast.module_name)
+      (string_of_name im.it.Ast.item_name) annotation
 
 let print_export m ex =
   let open Types in
@@ -210,7 +213,7 @@ let print_export m ex =
     | ExternalGlobalType t -> "global", string_of_global_type t
   in
   Printf.printf "  export %s %S : %s\n"
-    category (String.escaped ex.it.Ast.name) annotation
+    category (string_of_name ex.it.Ast.name) annotation
 
 let print_module x_opt m =
   Printf.printf "module%s :\n"
@@ -272,7 +275,7 @@ let run_definition def =
 let run_action act =
   match act.it with
   | Invoke (x_opt, name, vs) ->
-    trace ("Invoking function \"" ^ name ^ "\"...");
+    trace ("Invoking function \"" ^ string_of_name name ^ "\"...");
     let inst = lookup_instance x_opt act.at in
     (match Instance.export inst name with
     | Some (Instance.ExternalFunc f) ->
@@ -282,7 +285,7 @@ let run_action act =
     )
 
  | Get (x_opt, name) ->
-    trace ("Getting global \"" ^ name ^ "\"...");
+    trace ("Getting global \"" ^ string_of_name name ^ "\"...");
     let inst = lookup_instance x_opt act.at in
     (match Instance.export inst name with
     | Some (Instance.ExternalGlobal v) -> [v]
@@ -298,7 +301,10 @@ let assert_result at correct got print_expect expect =
   end
 
 let assert_message at name msg re =
-  if String.sub msg 0 (String.length re) <> re then begin
+  if
+    String.length msg < String.length re ||
+    String.sub msg 0 (String.length re) <> re
+  then begin
     print_endline ("Result: \"" ^ msg ^ "\"");
     print_endline ("Expect: \"" ^ re ^ "\"");
     Assert.error at ("wrong " ^ name ^ " error")
@@ -419,10 +425,10 @@ let rec run_command cmd =
   | Register (name, x_opt) ->
     quote := cmd :: !quote;
     if not !Flags.dry then begin
-      trace ("Registering module \"" ^ name ^ "\"...");
+      trace ("Registering module \"" ^ string_of_name name ^ "\"...");
       let inst = lookup_instance x_opt cmd.at in
-      registry := Map.add name inst !registry;
-      Import.register name (lookup_registry name)
+      registry := Map.add (Utf8.encode name) inst !registry;
+      Import.register name (lookup_registry (Utf8.encode name))
     end
 
   | Action act ->

interpreter/spec/ast.ml

@@ -65,6 +65,7 @@ type storeop = Memory.mem_size memop
 
 type var = int32 Source.phrase
 type literal = Values.value Source.phrase
+type name = int list
 
 type instr = instr' Source.phrase
 and instr' =
@@ -156,7 +157,7 @@ and export_desc' =
 type export = export' Source.phrase
 and export' =
 {
-  name : string;
+  name : name;
   edesc : export_desc;
 }
 
@@ -170,8 +171,8 @@ and import_desc' =
 type import = import' Source.phrase
 and import' =
 {
-  module_name : string;
-  item_name : string;
+  module_name : name;
+  item_name : name;
   idesc : import_desc;
 }
 

interpreter/spec/decode.ml

@@ -114,6 +114,11 @@ let rec list f n s = if n = 0 then [] else let x = f s in x :: list f (n - 1) s
 let opt f b s = if b then Some (f s) else None
 let vec f s = let n = len32 s in list f n s
 
+let name s =
+  let pos = pos s in
+  try Utf8.decode (string s) with Utf8.Utf8 ->
+    error s pos "invalid UTF-8 encoding"
+
 let sized f s =
   let size = len32 s in
   let start = pos s in
@@ -491,8 +496,8 @@ let import_desc s =
   | _ -> error s (pos s - 1) "invalid import kind"
 
 let import s =
-  let module_name = string s in
-  let item_name = string s in
+  let module_name = name s in
+  let item_name = name s in
   let idesc = at import_desc s in
   {module_name; item_name; idesc}
 
@@ -548,7 +553,7 @@ let export_desc s =
   | _ -> error s (pos s - 1) "invalid export kind"
 
 let export s =
-  let name = string s in
+  let name = name s in
   let edesc = at export_desc s in
   {name; edesc}
 
@@ -607,7 +612,7 @@ let data_section s =
 
 let custom size s =
   let start = pos s in
-  let _id = string s in
+  let _id = name s in
   skip (size - (pos s - start)) s;
   true
 

interpreter/spec/encode.ml

@@ -71,6 +71,7 @@ let encode m =
 
     let bool b = vu1 (if b then 1 else 0)
     let string bs = len (String.length bs); put_string s bs
+    let name n = string (Utf8.encode n)
     let list f xs = List.iter f xs
     let opt f xo = Lib.Option.app f xo
     let vec f xs = len (List.length xs); list f xs
@@ -390,7 +391,7 @@ let encode m =
 
     let import im =
       let {module_name; item_name; idesc} = im.it in
-      string module_name; string item_name; import_desc idesc
+      name module_name; name item_name; import_desc idesc
 
     let import_section ims =
       section 2 (vec import) ims (ims <> [])
@@ -434,8 +435,8 @@ let encode m =
       | GlobalExport x -> u8 3; var x
 
     let export ex =
-      let {name; edesc} = ex.it in
-      string name; export_desc edesc
+      let {name = n; edesc} = ex.it in
+      name n; export_desc edesc
 
     let export_section exs =
       section 7 (vec export) exs (exs <> [])

interpreter/spec/instance.ml

@@ -1,6 +1,6 @@
 open Values
 
-module ExportMap = Map.Make(String)
+module ExportMap = Map.Make(struct type t = Ast.name let compare = compare end)
 
 type global = value ref
 

interpreter/spec/utf8.ml

@@ -0,0 +1,42 @@
+exception Utf8
+
+let con n = 0x80 lor (n land 0x3f)
+
+let rec encode ns = Lib.String.implode (List.map Char.chr (encode' ns))
+and encode' = function
+  | [] -> []
+  | n::ns when n < 0 ->
+    raise Utf8
+  | n::ns when n < 0x80 ->
+    n :: encode' ns
+  | n::ns when n < 0x800 ->
+    0xc0 lor (n lsr 6) :: con n :: encode' ns
+  | n::ns when n < 0x10000 ->
+    0xe0 lor (n lsr 12) :: con (n lsr 6) :: con n :: encode' ns
+  | n::ns when n < 0x110000 ->
+    0xf0 lor (n lsr 18) :: con (n lsr 12) :: con (n lsr 6) :: con n
+    :: encode' ns
+  | _ ->
+    raise Utf8
+
+let con b = if b land 0xc0 = 0x80 then b land 0x3f else raise Utf8
+let code min n =
+  if n < min || (0xd800 <= n && n < 0xe000) || n >= 0x110000 then raise Utf8
+  else n
+
+let rec decode s = decode' (List.map Char.code (Lib.String.explode s))
+and decode' = function
+  | [] -> []
+  | b1::bs when b1 < 0x80 ->
+    code 0x0 b1 :: decode' bs
+  | b1::bs when b1 < 0xc0 ->
+    raise Utf8
+  | b1::b2::bs when b1 < 0xe0 ->
+    code 0x80 ((b1 land 0x1f) lsl 6 + con b2) :: decode' bs
+  | b1::b2::b3::bs when b1 < 0xf0 ->
+    code 0x800 ((b1 land 0x0f) lsl 12 + con b2 lsl 6 + con b3) :: decode' bs
+  | b1::b2::b3::b4::bs when b1 < 0xf8 ->
+    code 0x10000 ((b1 land 0x07) lsl 18 + con b2 lsl 12 + con b3 lsl 6 + con b4)
+    :: decode' bs
+  | _ ->
+    raise Utf8

interpreter/spec/utf8.mli

@@ -0,0 +1,4 @@
+exception Utf8
+
+val decode : string -> int list (* raise UTf8 *)
+val encode : int list -> string (* raise Utf8 *)

interpreter/spec/valid.ml

@@ -409,7 +409,7 @@ let check_import (im : import) (c : context) : context =
       "mutable globals cannot be imported (yet)";
     {c with globals = t :: c.globals}
 
-module NameSet = Set.Make(String)
+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 {name; edesc} = ex.it in