package jasmin

  1. Overview
  2. Docs
package jasmin
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file annot.ml

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