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
open! Core_kernel
open Poly
include Flags_intf
let create ~bit:n =
if n < 0 || n > 62
then
failwiths
~here:[%here]
"Flags.create got invalid ~bit (must be between 0 and 62)"
n
[%sexp_of: int];
Int63.shift_left Int63.one n
;;
module Make (M : Make_arg) = struct
type t = Int63.t [@@deriving bin_io, hash, typerep]
let of_int = Int63.of_int
let to_int_exn = Int63.to_int_exn
let empty = Int63.zero
let is_empty t = t = empty
let ( + ) a b = Int63.bit_or a b
let ( - ) a b = Int63.bit_and a (Int63.bit_not b)
let intersect = Int63.bit_and
let complement = Int63.bit_not
let is_subset t ~of_ = Int63.( = ) t (intersect t of_)
let do_intersect t1 t2 = Int63.( <> ) (Int63.bit_and t1 t2) Int63.zero
let are_disjoint t1 t2 = Int63.( = ) (Int63.bit_and t1 t2) Int63.zero
let error message a sexp_of_a =
let e = Error.create message a sexp_of_a in
if M.should_print_error
then eprintf "%s\n%!" (Sexp.to_string_hum (Error.sexp_of_t e));
Error.raise e
;;
let known =
if M.remove_zero_flags
then List.filter ~f:(fun (n, _) -> not (Int63.equal n Int63.zero)) M.known
else M.known
;;
let () =
if not M.allow_intersecting
then (
let rec check l ac =
match l with
| [] -> ac
| (flag, name) :: l ->
let bad = List.filter l ~f:(fun (flag', _) -> do_intersect flag flag') in
let ac = if List.is_empty bad then ac else (flag, name, bad) :: ac in
check l ac
in
let bad = check known [] in
if not (List.is_empty bad)
then
error
"Flags.Make got intersecting flags"
bad
[%sexp_of: (Int63.t * string * (Int63.t * string) list) list])
;;
let () =
let bad = List.filter known ~f:(fun (flag, _) -> flag = Int63.zero) in
if not (List.is_empty bad)
then
error
"Flag.Make got flags with no bits set"
bad
[%sexp_of: (Int63.t * string) list]
;;
type sexp_format = string list [@@deriving sexp]
let sexp_of_t =
let known = List.rev known in
fun t ->
let leftover, flag_names =
List.fold known ~init:(t, []) ~f:(fun (t, flag_names) (flag, flag_name) ->
if Int63.bit_and t flag = flag
then t - flag, flag_name :: flag_names
else t, flag_names)
in
if leftover = empty
then [%sexp_of: sexp_format] flag_names
else
[%sexp_of: string list * [ `unrecognized_bits of string ]]
(flag_names, `unrecognized_bits (sprintf "0x%Lx" (Int63.to_int64 leftover)))
;;
let known_by_name =
String.Table.of_alist_exn (List.map known ~f:(fun (mask, name) -> name, mask))
;;
let t_of_sexp sexp =
List.fold
(sexp |> [%of_sexp: sexp_format])
~init:empty
~f:(fun t name ->
match Hashtbl.find known_by_name name with
| Some mask -> t + mask
| None ->
of_sexp_error (sprintf "Flags.t_of_sexp got unknown name: %s" name) sexp)
;;
let compare t u =
let flip_top_bit i = Int63.( + ) i Int63.min_value in
Int63.compare (flip_top_bit t) (flip_top_bit u)
;;
include Comparable.Make (struct
type nonrec t = t [@@deriving sexp, compare, hash]
end)
let equal = Int63.( = )
let ( = ) = Int63.( = )
let ( <> ) = Int63.( <> )
module Unstable = struct
type nonrec t = t [@@deriving bin_io, compare, sexp]
end
end