package containers

You can search for identifiers within the package.

in-package search v0.2.0

A modular, clean and powerful extension of the OCaml standard library

Install

Dune Dependency

github.com Readme Changelog Edit opam file Versions (23)

Authors

C

c-cube

Maintainers

C

c-cube

Sources

containers-3.15.tbz

sha256=92143ceb4785ae5f8a07f3ab4ab9f6f32d31ead0536e9be4fdb818dd3c677e58

sha512=5fa80189d0e177af2302b48e72b70299d51fc36ac2019e1cbf389ff6a7f4705b10089405b5a719b3e4845b0d1349a47a967f865dc2e4e3f0d5a0167ef6c31431

doc/src/containers.codegen/containers_codegen.ml.html

Source file `containers_codegen.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
(** {1 Code generators} *)

module Fmt = CCFormat

let spf = Printf.sprintf
let fpf = Fmt.fprintf

type code =
  | Base of { pp: unit Fmt.printer }
  | Struct of string * code list
  | Sig of string * code list

module Code = struct
  type t = code

  let in_struct m (cs : t list) : t = Struct (m, cs)
  let in_sig m (cs : t list) : t = Sig (m, cs)

  let rec pp_rec out c =
    let ppl = Fmt.(list ~sep:(return "@ ") pp_rec) in
    match c with
    | Base { pp } -> pp out ()
    | Struct (m, cs) ->
      fpf out "@[<hv2>module %s = struct@ %a@;<1 -2>end@]" m ppl cs
    | Sig (m, cs) -> fpf out "@[<hv2>module %s : sig@ %a@;<1 -2>end@]" m ppl cs

  let pp out c = fpf out "@[<v>%a@]" pp_rec c
  let to_string c = Fmt.to_string pp c
  let mk_pp pp = Base { pp }
  let mk_str s = Base { pp = Fmt.const Fmt.string s }
end

module Bitfield = struct
  type field = {
    f_name: string;
    f_offset: int;
    f_def: field_def;
  }

  and field_def =
    | F_bit
    | F_int of { width: int }

  type t = {
    name: string;
    mutable fields: field list;
    mutable width: int;
    emit_failure_if_too_wide: bool;
  }

  let make ?(emit_failure_if_too_wide = true) ~name () : t =
    { name; fields = []; width = 0; emit_failure_if_too_wide }

  let total_width self = self.width

  let field_bit self f_name =
    let f_offset = total_width self in
    let f = { f_name; f_offset; f_def = F_bit } in
    self.fields <- f :: self.fields;
    self.width <- 1 + self.width

  let field_int self ~width f_name : unit =
    let f_offset = total_width self in
    let f = { f_name; f_offset; f_def = F_int { width } } in
    self.fields <- f :: self.fields;
    self.width <- self.width + width

  let empty_name self =
    if self.name = "t" then
      "empty"
    else
      spf "empty_%s" self.name

  let gen_ml self : code =
    Code.mk_pp @@ fun out () ->
    fpf out "@[<v>type %s = int@," self.name;
    fpf out "@[let %s : %s = 0@]@," (empty_name self) self.name;
    List.iter
      (fun f ->
        let inline = "[@inline]" in
        (* TODO: option to enable/disable that *)
        let off = f.f_offset in
        match f.f_def with
        | F_bit ->
          let x_lsr =
            if off = 0 then
              "x"
            else
              spf "(x lsr %d)" off
          in
          fpf out "@[let%s get_%s (x:%s) : bool = (%s land 1) <> 0@]@," inline
            f.f_name self.name x_lsr;
          let mask_shifted = 1 lsl off in
          fpf out
            "@[<2>let%s set_%s (v:bool) (x:%s) : %s =@ if v then x lor %d else \
             x land (lnot %d)@]@,"
            inline f.f_name self.name self.name mask_shifted mask_shifted
        | F_int { width } ->
          let mask0 = (1 lsl width) - 1 in
          fpf out "@[let%s get_%s (x:%s) : int = ((x lsr %d) land %d)@]@,"
            inline f.f_name self.name off mask0;
          fpf out
            "@[<2>let%s set_%s (i:int) (x:%s) : %s =@ assert ((i land %d) == \
             i);@ ((x land (lnot %d)) lor (i lsl %d))@]@,"
            inline f.f_name self.name self.name mask0 (mask0 lsl off) off)
      (List.rev self.fields);
    (* check width *)
    if self.emit_failure_if_too_wide then
      fpf out
        "(* check that int size is big enough *)@,\
         @[let () = assert (Sys.int_size >= %d);;@]" (total_width self);
    fpf out "@]"

  let gen_mli self : code =
    Code.mk_pp @@ fun out () ->
    fpf out "@[<v>type %s = private int@," self.name;
    fpf out "@[<v>val %s : %s@," (empty_name self) self.name;
    List.iter
      (fun f ->
        match f.f_def with
        | F_bit ->
          fpf out "@[val get_%s : %s -> bool@]@," f.f_name self.name;
          fpf out "@[val set_%s : bool -> %s -> %s@]@," f.f_name self.name
            self.name
        | F_int { width } ->
          fpf out "@[val get_%s : %s -> int@]@," f.f_name self.name;
          fpf out
            "@,@[(** %d bits integer *)@]@,@[val set_%s : int -> %s -> %s@]@,"
            width f.f_name self.name self.name)
      (List.rev self.fields);
    fpf out "@]"
end

let emit_chan oc cs =
  let fmt = Fmt.formatter_of_out_channel oc in
  List.iter (fun c -> Fmt.fprintf fmt "@[%a@]@." Code.pp c) cs;
  Fmt.fprintf fmt "@?"

let emit_file file cs = CCIO.with_out file (fun oc -> emit_chan oc cs)

let emit_string cs : string =
  Fmt.asprintf "@[<v>%a@]" (Fmt.list ~sep:(Fmt.return "@ ") Code.pp) cs