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
124
125
126
127
128
129
130
131
132
133
134
135
open Fmt
open Text
let sp ppf () = Fmt.char ppf ' '
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 Concrete_v128.t
| Const_null of heap_type option
| 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" Concrete_v128.pp v
| Const_null None -> pf fmt "ref.null"
| Const_null (Some 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_bis fmt = function
| Result_const c -> pf fmt "%a" pp_result_const c
| Result_extern_ref -> pf fmt "ref.extern"
| Result_func_ref -> pf fmt "ref.func"
let pp_result fmt r = Fmt.pf fmt "(%a)" pp_result_bis r
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 Module.t * string
| Assert_malformed of Module.t * string
| Assert_malformed_quote of string * string
| Assert_malformed_binary of string * string
| Assert_invalid of Module.t * string
| Assert_invalid_quote of string * string
| Assert_invalid_binary of string * string
| Assert_exhaustion of action * string
| Assert_unlinkable of Module.t * 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")|} Module.pp m f
| Assert_invalid (m, msg) ->
pf fmt "(assert_invalid@\n @[<v>%a@]@\n @[<v>%S@]@\n)" Module.pp m msg
| Assert_unlinkable (m, msg) ->
pf fmt "(assert_unlinkable@\n @[<v>%a@]@\n @[<v>%S@]@\n)" Module.pp m msg
| Assert_malformed (m, msg) ->
pf fmt "(assert_malformed (module binary@\n @[<v>%a@])@\n @[<v>%S@]@\n)"
Module.pp 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_module_kind fmt = function
| true -> Fmt.pf fmt " definition"
| false -> ()
type cmd =
| Quoted_module of bool * string
| Binary_module of bool * string option * string
| Text_module of bool * Module.t
| Instance of string option * string
| Assert of assertion
| Register of string * string option
| Action of action
let pp_str_opt fmt = function None -> () | Some s -> Fmt.pf fmt " %s" s
let pp_cmd fmt = function
| Quoted_module (kind, m) -> pf fmt "(module%a %S)" pp_module_kind kind m
| Binary_module (kind, id, m) ->
Fmt.pf fmt "(module%a %a %S)" pp_module_kind kind Text.pp_id_opt id m
| Text_module (kind, m) ->
pf fmt "(module%a%a@\n @[<v>%a@]@\n)" pp_module_kind kind pp_id_opt m.id
Text.Module.pp_fields m.fields
| Instance (id, module_id) ->
pf fmt "(module instance%a %s)" pp_str_opt id module_id
| Assert a -> pp_assertion fmt a
| Register (name, id) -> pf fmt "(register %s%a)" name pp_str_opt id
| Action _a -> pf fmt "<action>"
type script = cmd list
let pp_script fmt l = list ~sep:pp_newline pp_cmd fmt l