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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
(* SPDX-License-Identifier: AGPL-3.0-or-later *)
(* Copyright © 2021-2024 OCamlPro *)
(* Written by the Owi programmers *)
open Fmt
open Types
let symbolic v = Text v
let raw v = Raw v
let bt_ind i = Bt_ind i
let bt_raw i t = Bt_raw (i, t)
type global =
{ typ : text global_type
; init : text expr
; id : string option
}
let pp_global fmt (g : global) =
pf fmt "(global%a %a %a)" pp_id_opt g.id pp_global_type g.typ pp_expr g.init
type data_mode =
| Data_passive
| Data_active of text indice option * text expr
let pp_data_mode fmt = function
| Data_passive -> ()
| Data_active (i, e) ->
pf fmt "(memory %a) (offset %a)" pp_indice_opt i pp_expr e
type data =
{ id : string option
; init : string
; mode : data_mode
}
let pp_data fmt (d : data) =
pf fmt {|(data%a %a %S)|} pp_id_opt d.id pp_data_mode d.mode d.init
type elem_mode =
| Elem_passive
| Elem_active of text indice option * text expr
| Elem_declarative
let pp_elem_mode fmt = function
| Elem_passive -> ()
| Elem_declarative -> pf fmt "declare"
| Elem_active (i, e) -> (
match i with
| None -> pf fmt "(offset %a)" pp_expr e
| Some i -> pf fmt "(table %a) (offset %a)" pp_indice i pp_expr e )
type elem =
{ id : string option
; typ : text ref_type
; init : text expr list
; mode : elem_mode
}
let pp_elem_expr fmt e = pf fmt "(item %a)" pp_expr e
let pp_elem fmt (e : elem) =
pf fmt "@[<hov 2>(elem%a %a %a %a)@]" pp_id_opt e.id pp_elem_mode e.mode
pp_ref_type e.typ
(list ~sep:pp_newline pp_elem_expr)
e.init
type module_field =
| MType of text rec_type
| MGlobal of global
| MTable of text table
| MMem of mem
| MFunc of text func
| MElem of elem
| MData of data
| MStart of text indice
| MImport of text import
| MExport of text export
let pp_module_field fmt = function
| MType t -> pp_rec_type fmt t
| MGlobal g -> pp_global fmt g
| MTable t -> pp_table fmt t
| MMem m -> pp_mem fmt m
| MFunc f -> pp_func fmt f
| MElem e -> pp_elem fmt e
| MData d -> pp_data fmt d
| MStart s -> pp_start fmt s
| MImport i -> pp_import fmt i
| MExport e -> pp_export fmt e
type modul =
{ id : string option
; fields : module_field list
}
let pp_modul fmt (m : modul) =
pf fmt "(module%a@\n @[<v>%a@]@\n)" pp_id_opt m.id
(list ~sep:pp_newline pp_module_field)
m.fields
type action =
| Invoke of string option * string * text 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 text 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)" Types.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