package dolmen

  1. Overview
  2. Docs

Source file escape.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
(* This file is free software, part of Archsat. See file "LICENSE" for more details. *)

(* Wrapper around polymorphic identifiers *)
(* ************************************************************************ *)

module type Arg = Dolmen_intf.Id.Escape

(* Escaping helper *)
(* ************************************************************************ *)

let smap f s =
  let b = Buffer.create (String.length s) in
  let rec aux i =
    if i >= String.length s then
      Buffer.contents b
    else begin
      Buffer.add_string b (f (i + 1) s.[i]);
      aux (i + 1)
    end
  in
  aux 0

(* Renaming function *)
(* ************************************************************************ *)

let get_num ~sep s =
  let rec aux acc mult i =
    if i < 0 then s, 0
    else match s.[i] with
      | ('0' .. '9') as c ->
        let j = int_of_char c - 48 in
        aux (acc + j * mult) (mult * 10) (i - 1)
      | c when c = sep ->
        if i = 0 then s, 0 (* no base name found *)
        else String.sub s 0 i, acc
      | _ -> s, 0
  in
  aux 0 1 (String.length s - 1)

let rename ~sep s =
  let base, n = get_num ~sep s in
  Format.sprintf "%s%c%d" base sep (n + 1)


(* Printing wrappers for escapped sequences *)
(* ************************************************************************ *)

type status =
  | Same    (* No changes to the identifiers name *)
  | Escaped (* Identifiers has been escaped *)
  | Renamed (* Identifier has been renamed due to a conflict
               with another escaped or renamed identifier *)

module Make(Id : Arg) = struct

  module H = Hashtbl.Make(Id)

  type t = {
    lang   : string;
    name   : Id.t -> string;     (* function for identifier name *)
    escape : string -> string;  (* escape function, ideally idempotent *)
    rename : string -> string;  (* renaming function, should have no fixpoint *)
    mutable table : (status * string) H.t;
    mutable names : (string, Id.t) Hashtbl.t;
  }

  let mk ~lang ~name ~escape ~rename = {
    lang; name;
    escape; rename;
    table = H.create 1013;
    names = Hashtbl.create 1013;
  }

  let flush t =
    Hashtbl.reset t.names;
    H.reset t.table;
    ()

  (* Adding escapped sequences *)
  (* ************************************************************************ *)

  let rec add t id status name =
    match Hashtbl.find t.names name with
    | exception Not_found ->
      add_success t id status name
    | r ->
      assert (not (Id.equal id r));
      add_failure t id name

  and add_success t any status name =
    let () = H.add t.table any (status, name) in
    let () = Hashtbl.add t.names name any in
    name

  and add_failure t id name =
    let new_name = t.rename name in
    assert (new_name <> name);
    add t id Renamed new_name

  let escape t id =
    match H.find t.table id with
    | (_, s) -> s
    | exception Not_found ->
      let name = t.name id in
      let escaped = t.escape (t.name id) in
      let status, new_name =
        if (escaped = name)
        then Same, name (* allow the gc to reclaim 'escaped' *)
        else Escaped, escaped
      in
      add t id status new_name

  (* Convenience functions *)
  (* ************************************************************************ *)

  let print t fmt id =
    Format.fprintf fmt "%s" (escape t id)

end