let exports = exports m in

mods.current <- mods.current + 1;

mods.env <- Map.add (of_var_opt mods x_opt) exports mods.env;

let exports =

try Map.find (of_var_opt mods x_opt) mods.env with Not_found ->

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 NameMap.find name exports with Not_found ->

raise (Eval.Crash (at, "unknown export \"" ^

| I32Type -> Values.I32 I32Op.Eq

| I64Type -> Values.I64 I64Op.Eq

| F32Type -> Values.F32 F32Op.Eq

| I32Type -> I32Type, Nop

| I64Type -> I64Type, Nop

| F32Type -> I32Type, Convert (Values.I32 I32Op.ReinterpretFloat)

match v.it with

| Values.Num n -> [Const (n @@ v.at) @@ v.at]

| Values.Vec s -> [VecConst (s @@ v.at) @@ v.at]

| Values.Ref (Values.NullRef t) -> [RefNull t @@ v.at]

| Values.Ref (ExternRef n) ->

[Const (Values.I32 n @@ v.at) @@ v.at; Call (externref_idx @@ v.at) @@ v.at]

let test res =

let nan_bitmask_of = function

| CanonicalNan -> abs_mask_of (* must only differ from the canonical NaN in its sign bit *)

| ArithmeticNan -> canonical_nan_of (* can be any NaN that's one everywhere the canonical NaN is one *)

in

match res.it with

| NumResult (NumPat {it = num; at = at'}) ->

let t', reinterpret = reinterpret_of (Values.type_of_num num) in

[ reinterpret @@ at;

Const (num @@ at') @@ at;

reinterpret @@ at;

Compare (eq_of t') @@ at;

Test (Values.I32 I32Op.Eqz) @@ at;

BrIf (0l @@ at) @@ at ]

| NumResult (NanPat nanop) ->

let nan =

match nanop.it with

| Values.I32 _ | Values.I64 _ -> .

| Values.F32 n | Values.F64 n -> n

in

let t = Values.type_of_num nanop.it in

let t', reinterpret = reinterpret_of t in

[ reinterpret @@ at;

Const (nan_bitmask_of nan t' @@ at) @@ at;

Binary (and_of t') @@ at;

Const (canonical_nan_of t' @@ at) @@ at;

Compare (eq_of t') @@ at;

Test (Values.I32 I32Op.Eqz) @@ at;

BrIf (0l @@ at) @@ at ]

| VecResult (VecPat (Values.V128 (shape, pats))) ->

let open Values in

(* VecResult is a list of NumPat or LitPat. For float shapes, we can have a mix of literals

let mask_and_canonical = function

| NumPat {it = I32 _ as i; _} -> I32 (Int32.minus_one), i

| NumPat {it = I64 _ as i; _} -> I64 (Int64.minus_one), i

| NumPat {it = F32 f; _} ->

I32 (Int32.minus_one), I32 (I32_convert.reinterpret_f32 f)

| NumPat {it = F64 f; _} ->

I64 (Int64.minus_one), I64 (I64_convert.reinterpret_f64 f)

| NanPat {it = F32 nan; _} ->

nan_bitmask_of nan I32Type, canonical_nan_of I32Type

| NanPat {it = F64 nan; _} ->

nan_bitmask_of nan I64Type, canonical_nan_of I64Type

| _ -> .

in

let masks, canons = List.split (List.map (fun p -> mask_and_canonical p) pats) in

let all_ones = V128.I32x4.of_lanes (List.init 4 (fun _ -> Int32.minus_one)) in

let mask, expected = match shape with

| V128.I8x16 () ->

all_ones, V128.I8x16.of_lanes (List.map (I32Num.of_num 0) canons)

| V128.I16x8 () ->

all_ones, V128.I16x8.of_lanes (List.map (I32Num.of_num 0) canons)

| V128.I32x4 () ->

all_ones, V128.I32x4.of_lanes (List.map (I32Num.of_num 0) canons)

| V128.I64x2 () ->

all_ones, V128.I64x2.of_lanes (List.map (I64Num.of_num 0) canons)

| V128.F32x4 () ->

V128.I32x4.of_lanes (List.map (I32Num.of_num 0) masks),

V128.I32x4.of_lanes (List.map (I32Num.of_num 0) canons)

| V128.F64x2 () ->

V128.I64x2.of_lanes (List.map (I64Num.of_num 0) masks),

V128.I64x2.of_lanes (List.map (I64Num.of_num 0) canons)

in

[ VecConst (V128 mask @@ at) @@ at;

VecBinaryBits (V128 V128Op.And) @@ at;

VecConst (V128 expected @@ at) @@ at;

VecCompare (V128 (V128.I8x16 V128Op.Eq)) @@ at;

(* If all lanes are non-zero, then they are equal *)

VecTest (V128 (V128.I8x16 V128Op.AllTrue)) @@ at;

Test (I32 I32Op.Eqz) @@ at;

BrIf (0l @@ at) @@ at ]

| RefResult (RefPat {it = Values.NullRef t; _}) ->

[ RefIsNull @@ at;

Test (Values.I32 I32Op.Eqz) @@ at;

BrIf (0l @@ at) @@ at ]

| RefResult (RefPat {it = ExternRef n; _}) ->

[ Const (Values.I32 n @@ at) @@ at;

Call (externref_idx @@ at) @@ at;

Call (eq_externref_idx @@ at) @@ at;

Test (Values.I32 I32Op.Eqz) @@ at;

BrIf (0l @@ at) @@ at ]

| RefResult (RefPat _) ->

assert false

| RefResult (RefTypePat t) ->

let is_ref_idx =

match t with

| FuncRefType -> is_funcref_idx

| ExternRefType -> is_externref_idx

in

[ Call (is_ref_idx @@ at) @@ at;

Test (Values.I32 I32Op.Eqz) @@ at;

BrIf (0l @@ at) @@ at ]

let itypes, idesc, action = wrap_action at in

let locals, assertion = wrap_assertion at in

let types =

(FuncType ([], []) @@ at) ::

(FuncType ([NumType I32Type], [RefType ExternRefType]) @@ at) ::

(FuncType ([RefType ExternRefType], [NumType I32Type]) @@ at) ::

(FuncType ([RefType FuncRefType], [NumType I32Type]) @@ at) ::

(FuncType ([RefType ExternRefType; RefType ExternRefType], [NumType I32Type]) @@ at) ::

(FuncType ([RefType FuncRefType; RefType FuncRefType], [NumType I32Type]) @@ at) ::

itypes

in

let imports =

[ {module_name = Utf8.decode "module"; item_name; idesc} @@ at;

{module_name = Utf8.decode "spectest"; item_name = Utf8.decode "externref";

idesc = FuncImport (1l @@ at) @@ at} @@ at;

{module_name = Utf8.decode "spectest"; item_name = Utf8.decode "is_externref";

idesc = FuncImport (2l @@ at) @@ at} @@ at;

{module_name = Utf8.decode "spectest"; item_name = Utf8.decode "is_funcref";

idesc = FuncImport (3l @@ at) @@ at} @@ at;

{module_name = Utf8.decode "spectest"; item_name = Utf8.decode "eq_externref";

idesc = FuncImport (4l @@ at) @@ at} @@ at;

{module_name = Utf8.decode "spectest"; item_name = Utf8.decode "eq_funcref";

idesc = FuncImport (5l @@ at) @@ at} @@ at ]

in

let item =

List.fold_left

(fun i im ->

match im.it.idesc.it with FuncImport _ -> Int32.add i 1l | _ -> i

) 0l imports @@ at

in

let edesc = FuncExport item @@ at in

let exports = [{name = Utf8.decode "run"; edesc} @@ at] in

let body =

[ Block (ValBlockType None, action @ assertion @ [Return @@ at]) @@ at;

Unreachable @@ at ]

in

let funcs = [{ftype = 0l @@ at; locals; body} @@ at] in

let m = {empty_module with types; funcs; imports; exports} @@ at in

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

if uc < 0x20 || uc >= 0x7f then

Printf.bprintf buf "\\u{%02x}" uc

else

let buf = Buffer.create 256 in

Buffer.add_char buf '\"';

iter (add_char buf) s;

Buffer.add_char buf '\"';

match string_of_float z with

| "nan" -> "NaN"

| "-nan" -> "-NaN"

| "inf" -> "Infinity"

| "-inf" -> "-Infinity"

let open Values in

match n with

| I32 i -> I32.to_string_s i

| I64 i -> "int64(\"" ^ I64.to_string_s i ^ "\")"

| F32 z -> of_float (F32.to_float z)

let open Values in

match r with

| NullRef _ -> "null"

| ExternRef n -> "externref(" ^ Int32.to_string n ^ ")"

let open Values in

match v.it with

| Num n -> of_num n

| Vec v -> of_vec v

| NumPat num -> of_num num.it

| NanPat nanop ->

match nanop.it with

| Values.I32 _ | Values.I64 _ -> .

match res.it with

| NumResult np -> of_num_pat np

| VecResult vp -> of_vec_pat vp

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 _ ->

let x = of_var_opt mods x_opt in

let bs = wrap name wrap_action wrap_assertion at in

"call(instance(" ^ of_bytes bs ^ ", " ^

match act.it with

| Invoke (x_opt, name, vs) ->

"call(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ", " ^

"[" ^ String.concat ", " (List.map of_value vs) ^ "])",

(match lookup mods x_opt name act.at with

| ExternFuncType ft when not (is_js_func_type ft) ->

let FuncType (_, out) = ft in

Some (of_wrapper mods x_opt name (invoke ft vs), out)

| _ -> None

)

| Get (x_opt, name) ->

"get(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ")",

(match lookup mods x_opt name act.at with

| ExternGlobalType gt when not (is_js_global_type gt) ->

let GlobalType (t, _) = gt in

Some (of_wrapper mods x_opt name (get gt), [t])

| _ -> None

let act_js, act_wrapper_opt = of_action mods act in

let js = name ^ "(() => " ^ act_js ^ String.concat ", " ("" :: args) ^ ")" in

match act_wrapper_opt with

| None -> js ^ ";"

| Some (act_wrapper, out) ->

let run_name, wrapper =

match wrapper_opt with

| None -> name, run

| Some wrapper -> "run", wrapper

match ass.it with

| AssertMalformed (def, _) ->

"assert_malformed(" ^ of_definition def ^ ");"

| AssertInvalid (def, _) ->

"assert_invalid(" ^ of_definition def ^ ");"

| AssertUnlinkable (def, _) ->

"assert_unlinkable(" ^ of_definition def ^ ");"

| AssertUninstantiable (def, _) ->

"assert_uninstantiable(" ^ of_definition def ^ ");"

| AssertReturn (act, ress) ->

of_assertion' mods act "assert_return" (List.map of_result ress)

(Some (assert_return ress))

| AssertTrap (act, _) ->

of_assertion' mods act "assert_trap" [] None

| AssertExhaustion (act, _) ->

"\n// " ^ Filename.basename cmd.at.left.file ^

":" ^ string_of_int cmd.at.left.line ^ "\n" ^

match cmd.it with

| Module (x_opt, def) ->

let rec unquote def =

match def.it with

| Textual m -> m

| Encoded (_, bs) -> Decode.decode "binary" bs

| 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")

| Register (name, x_opt) ->

"register(" ^ of_name name ^ ", " ^ of_var_opt mods x_opt ^ ")\n"

| Action act ->

of_assertion' mods act "run" [] None ^ "\n"

| Assertion ass ->

of_assertion mods ass ^ "\n"