1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
open Fmt
open Text
type const =
| Const_I32 of Int32.t
| Const_I64 of Int64.t
| Const_F32 of Float32.t
| Const_F64 of Float64.t
| Const_V128 of V128.t
| Const_null of heap_type
| Const_host of int
| Const_extern of int
let pp_const fmt c =
pf fmt "(%a)"
(fun fmt c ->
match c with
| Const_I32 i -> pf fmt "i32.const %ld" i
| Const_I64 i -> pf fmt "i64.const %Ld" i
| Const_F32 f -> pf fmt "f32.const %a" Float32.pp f
| Const_F64 f -> pf fmt "f64.const %a" Float64.pp f
| Const_V128 v -> pf fmt "v128.const %a" V128.pp v
| Const_null rt -> pf fmt "ref.null %a" pp_heap_type rt
| Const_host i -> pf fmt "ref.host %d" i
| Const_extern i -> pf fmt "ref.extern %d" i )
c
let pp_consts fmt c = list ~sep:sp pp_const fmt c
type action =
| Invoke of string option * string * const list
| Get of string option * string
let pp_action fmt = function
| Invoke (mod_name, name, c) ->
pf fmt {|(invoke%a "%s" %a)|} pp_id_opt mod_name name pp_consts c
| Get _ -> pf fmt "<action_get TODO>"
type result_const =
| Literal of const
| Nan_canon of nn
| Nan_arith of nn
let pp_result_const fmt = function
| Literal c -> pp_const fmt c
| Nan_canon n -> pf fmt "f%a.const nan:canonical" pp_nn n
| Nan_arith n -> pf fmt "f%a.const nan:arithmetic" pp_nn n
type result =
| Result_const of result_const
| Result_extern_ref
| Result_func_ref
let pp_result fmt = function
| Result_const c -> pf fmt "(%a)" pp_result_const c
| Result_func_ref | Result_extern_ref -> assert false
let pp_result_bis fmt = function
| Result_const c -> pf fmt "%a" pp_result_const c
| Result_extern_ref | Result_func_ref -> assert false
let pp_results fmt r = list ~sep:sp pp_result_bis fmt r
type assertion =
| Assert_return of action * result list
| Assert_trap of action * string
| Assert_trap_module of modul * string
| Assert_malformed of modul * string
| Assert_malformed_quote of string * string
| Assert_malformed_binary of string * string
| Assert_invalid of modul * string
| Assert_invalid_quote of string * string
| Assert_invalid_binary of string * string
| Assert_exhaustion of action * string
| Assert_unlinkable of modul * string
let pp_assertion fmt = function
| Assert_return (a, l) ->
pf fmt "(assert_return %a %a)" pp_action a pp_results l
| Assert_exhaustion (a, msg) ->
pf fmt "(assert_exhaustion %a %s)" pp_action a msg
| Assert_trap (a, f) -> pf fmt {|(assert_trap %a "%s")|} pp_action a f
| Assert_trap_module (m, f) ->
pf fmt {|(assert_trap_module %a "%s")|} pp_modul m f
| Assert_invalid (m, msg) ->
pf fmt "(assert_invalid@\n @[<v>%a@]@\n @[<v>%S@]@\n)" pp_modul m msg
| Assert_unlinkable (m, msg) ->
pf fmt "(assert_unlinkable@\n @[<v>%a@]@\n @[<v>%S@]@\n)" pp_modul m msg
| Assert_malformed (m, msg) ->
pf fmt "(assert_malformed (module binary@\n @[<v>%a@])@\n @[<v>%S@]@\n)"
pp_modul m msg
| Assert_malformed_quote (ls, msg) ->
pf fmt "(assert_malformed_quote@\n @[<v>%S@]@\n @[<v>%S@]@\n)" ls msg
| Assert_invalid_quote (ls, msg) ->
pf fmt "(assert_invalid_quote@\n @[<v>%S@]@\n @[<v>%S@]@\n)" ls msg
| Assert_malformed_binary (ls, msg) ->
pf fmt "(assert_malformed_binary@\n @[<v>%S@]@\n @[<v>%S@]@\n)" ls msg
| Assert_invalid_binary (ls, msg) ->
pf fmt "(assert_invalid_binary@\n @[<v>%S@]@\n @[<v>%S@]@\n)" ls msg
type register = string * string option
let pp_register fmt (s, _name) = pf fmt "(register %s)" s
type cmd =
| Quoted_module of string
| Binary_module of string option * string
| Text_module of modul
| Assert of assertion
| Register of string * string option
| Action of action
let pp_cmd fmt = function
| Quoted_module m -> pf fmt "(module %S)" m
| Binary_module (id, m) -> Fmt.pf fmt "(module %a %S)" Text.pp_id_opt id m
| Text_module m -> pp_modul fmt m
| Assert a -> pp_assertion fmt a
| Register (s, name) -> pp_register fmt (s, name)
| Action _a -> pf fmt "<action>"
type script = cmd list
let pp_script fmt l = list ~sep:pp_newline pp_cmd fmt l