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
open Utils
open Wsize
module L = Location
module A = Annotations
exception AnnotationError of Location.t * (Format.formatter -> unit)
let error ~loc = Format.kdprintf (fun msg -> raise (AnnotationError (loc, msg)))
let on_attribute ?on_empty ?on_int ?on_id ?on_string ?on_ws ?on_struct error
(id, attribute) =
let nid = L.unloc id in
let doit loc o arg =
match o with None -> error loc nid | Some f -> f loc nid arg
in
match attribute with
| None -> doit (L.loc id) on_empty ()
| Some a -> (
let loc = L.loc a in
match L.unloc a with
| A.Aint i -> doit loc on_int i
| A.Aid id -> doit loc on_id id
| A.Astring s -> doit loc on_string s
| A.Aws ws -> doit loc on_ws ws
| A.Astruct s -> doit loc on_struct s)
let pp_dfl_attribute pp fmt dfl =
match dfl with
| Some a -> Format.fprintf fmt "@ default is “%a”" pp a
| None -> ()
let error_attribute loc id pp a pp_dfl dfl =
error ~loc "attribute for “%s” should be %a%a" id pp a
(pp_dfl_attribute pp_dfl) dfl
let on_empty error dfl loc nid () =
match dfl with None -> error loc nid | Some d -> d
let filter_string_list dfl l arg =
let error loc nid =
assert (l <> []);
let pp fmt l =
Format.fprintf fmt "(@[%a@])"
(pp_list " |@ " (fun fmt (s, _) -> Format.pp_print_string fmt s))
l
in
error_attribute loc nid pp l Format.pp_print_string dfl
in
let on_string loc nid s =
try List.assoc s l with Not_found -> error loc nid
in
on_attribute
~on_empty:(fun loc nid () ->
on_string loc nid (on_empty error dfl loc nid ()))
~on_id:on_string ~on_string error arg
let bool dfl =
filter_string_list
(Some (if dfl then "yes" else "no"))
[ ("yes", true); ("no", false) ]
let none ((id, _) as arg) =
on_attribute
~on_empty:(fun _loc _nid () -> ())
(fun loc _nid ->
error ~loc "attribute for “%s” should be empty" (L.unloc id))
arg
let int dfl arg =
let error loc nid =
error_attribute loc nid Format.pp_print_string "an integer" Z.pp_print dfl
in
let on_empty loc nid () =
match dfl with Some i -> i | None -> error loc nid
in
let on_string loc nid s =
try Z.of_string s with Invalid_argument _ -> error loc nid
in
on_attribute ~on_empty ~on_int:(fun _loc _nid i -> i) ~on_string error arg
let pos_int dfl ((id, _) as arg) =
let i = int dfl arg in
if Z.lt i Z.zero then
error_attribute (L.loc id) (L.unloc id) Format.pp_print_string
"a positive integer" Z.pp_print dfl;
i
let string_of_ws ws = Annotations.string_of_ws ws
let ws_strings =
List.map
(fun ws -> (string_of_ws ws, ws))
[ U8; U16; U32; U64; U128; U256 ]
let ws_of_string =
fun s -> List.assoc s ws_strings
let wsize dfl arg =
let error loc nid =
error_attribute loc nid Format.pp_print_string "a word size"
(fun fmt ws -> Format.fprintf fmt "%s" (string_of_ws ws))
dfl
in
let on_empty loc nid () =
match dfl with Some ws -> ws | None -> error loc nid
in
let on_string loc nid s =
try ws_of_string s with Not_found -> error loc nid
in
let on_ws _loc _nid ws = ws in
on_attribute ~on_empty ~on_string ~on_ws error arg
let filter_attribute ?(case_sensitive = true) name (f : A.annotation -> 'a)
(annot : A.annotations) =
let test =
if case_sensitive then fun id -> L.unloc id = name
else
let name = String.uppercase_ascii name in
fun id -> String.uppercase_ascii (L.unloc id) = name
in
List.pmap
(fun ((id, _) as arg) -> if test id then Some (id, f arg) else None)
annot
let process_annot ?(case_sensitive = true)
(filters : (string * (A.annotation -> 'a)) list) annot =
List.flatten
(List.map
(fun (name, f) -> filter_attribute ~case_sensitive name f annot)
filters)
let ensure_uniq ?(case_sensitive = true)
(filters : (string * (A.annotation -> 'a)) list) annot =
match process_annot ~case_sensitive filters annot with
| [] -> None
| [ (_, r) ] -> Some r
| (id, _) :: _ as l ->
error ~loc:(L.loc id) "only one of the attribute %a is expected"
(pp_list ", " (fun fmt (id, _) -> Format.fprintf fmt "%s" (L.unloc id)))
l
let ensure_uniq1 ?(case_sensitive = true) id f annot =
ensure_uniq ~case_sensitive [ (id, f) ] annot
let consume id annot : A.annotations =
List.filter (fun (k, _) -> not (String.equal id (L.unloc k))) annot