simon/sidekick
1
0
Fork 0
mirror of https://github.com/c-cube/sidekick.git synced 2025-12-06 11:15:43 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

format

Browse source
This commit is contained in:
Simon Cruanes 2022-08-27 20:48:32 -04:00
parent df287e4ef7
commit 2a0feed32c
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
2 changed files with 35 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

55
src/smt/registry.ml
View file

@ -1,37 +1,38 @@
(* registry keys *)
module type KEY = sig
type elt
(* registry keys *) val id : int
module type KEY = sig
type elt
val id : int exception E of elt
end
exception E of elt type 'a key = (module KEY with type elt = 'a)
end type t = { tbl: exn Util.Int_tbl.t } [@@unboxed]
type 'a key = (module KEY with type elt = 'a) let create () : t = { tbl = Util.Int_tbl.create 8 }
type t = { tbl: exn Util.Int_tbl.t } [@@unboxed]
let create () : t = { tbl = Util.Int_tbl.create 8 } (* TODO: use atomic *)
let n_ = ref 0 let n_ = ref 0
let create_key (type a) () : a key = let create_key (type a) () : a key =
let id = !n_ in let id = !n_ in
incr n_; incr n_;
let module K = struct let module K = struct
type elt = a type elt = a
exception E of a exception E of a
let id = id let id = id
end in end in
(module K) (module K)
let get (type a) (self : t) (k : a key) : _ option = let get (type a) (self : t) (k : a key) : _ option =
let (module K : KEY with type elt = a) = k in let (module K : KEY with type elt = a) = k in
match Util.Int_tbl.get self.tbl K.id with match Util.Int_tbl.get self.tbl K.id with
| Some (K.E x) -> Some x | Some (K.E x) -> Some x
| _ -> None | _ -> None
let set (type a) (self : t) (k : a key) (v : a) : unit = let set (type a) (self : t) (k : a key) (v : a) : unit =
let (module K) = k in let (module K) = k in
Util.Int_tbl.replace self.tbl K.id (K.E v) Util.Int_tbl.replace self.tbl K.id (K.E v)

16
src/smt/registry.mli
View file

@ -1,14 +1,12 @@
(** Registry to extract values *) (** Registry to extract values *)
type t type t
type 'a key type 'a key
val create_key : unit -> 'a key val create_key : unit -> 'a key
(** Call this statically, typically at program initialization, for (** Call this statically, typically at program initialization, for
each distinct key. *) each distinct key. *)
val create : unit -> t val create : unit -> t
val get : t -> 'a key -> 'a option val get : t -> 'a key -> 'a option
val set : t -> 'a key -> 'a -> unit val set : t -> 'a key -> 'a -> unit