1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Pierre Chambart, OCamlPro *)
6 (* Mark Shinwell and Leo White, Jane Street Europe *)
7 (* *)
8 (* Copyright 2013--2016 OCamlPro SAS *)
9 (* Copyright 2014--2016 Jane Street Group LLC *)
10 (* *)
11 (* All rights reserved. This file is distributed under the terms of *)
12 (* the GNU Lesser General Public License version 2.1, with the *)
13 (* special exception on linking described in the file LICENSE. *)
14 (* *)
15 (**************************************************************************)
16
17 [@@@ocaml.warning "+a-4-9-30-40-41-42-66"]
18 open! Int_replace_polymorphic_compare
19
20 type t = {
21 compilation_unit : Compilation_unit.t;
22 name : string;
23 name_stamp : int;
24 (** [name_stamp]s are unique within any given compilation unit. *)
25 }
26
27 include Identifiable.Make (struct
28 type nonrec t = t
29
30 let compare t1 t2 =
31 if t1 == t2 then 0
32 else
33 let c = t1.name_stamp - t2.name_stamp in
34 if c <> 0 then c
35 else Compilation_unit.compare t1.compilation_unit t2.compilation_unit
36
37 let equal t1 t2 =
38 if t1 == t2 then true
39 else
40 t1.name_stamp = t2.name_stamp
41 && Compilation_unit.equal t1.compilation_unit t2.compilation_unit
42
43 let output chan t =
44 output_string chan t.name;
45 output_string chan "_";
46 output_string chan (Int.to_string t.name_stamp)
47
48 let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit)
49
50 let print ppf t =
51 if Compilation_unit.equal t.compilation_unit
52 (Compilation_unit.get_current_exn ())
53 then begin
54 Format.fprintf ppf "%s/%d"
55 t.name t.name_stamp
56 end else begin
57 Format.fprintf ppf "%a.%s/%d"
58 Compilation_unit.print t.compilation_unit
59 t.name t.name_stamp
60 end
61 end)
62
63 let previous_name_stamp = ref (-1)
64
65 let create_with_name_string ?current_compilation_unit name =
66 let compilation_unit =
67 match current_compilation_unit with
68 | Some compilation_unit -> compilation_unit
69 | None -> Compilation_unit.get_current_exn ()
70 in
71 let name_stamp =
72 incr previous_name_stamp;
73 !previous_name_stamp
74 in
75 { compilation_unit;
76 name;
77 name_stamp;
78 }
79
80 let create ?current_compilation_unit name =
81 let name = (name : Internal_variable_names.t :> string) in
82 create_with_name_string ?current_compilation_unit name
83
84 let create_with_same_name_as_ident ident =
85 create_with_name_string (Ident.name ident)
86
87 let rename ?current_compilation_unit t =
88 create_with_name_string ?current_compilation_unit t.name
89
90 let in_compilation_unit t cu =
91 Compilation_unit.equal cu t.compilation_unit
92
93 let get_compilation_unit t = t.compilation_unit
94
95 let name t = t.name
96
97 let unique_name t =
98 t.name ^ "_" ^ (Int.to_string t.name_stamp)
99
100 let print_list ppf ts =
101 List.iter (fun t -> Format.fprintf ppf "@ %a" print t) ts
102
103 let debug_when_stamp_matches t ~stamp ~f =
104 if t.name_stamp = stamp then f ()
105
106 let print_opt ppf = function
107 | None -> Format.fprintf ppf "<no var>"
108 | Some t -> print ppf t
109
110 type pair = t * t
111 module Pair = Identifiable.Make (Identifiable.Pair (T) (T))
112
113 let compare_lists l1 l2 =
114 Misc.Stdlib.List.compare compare l1 l2
115
116 let output_full chan t =
117 Compilation_unit.output chan t.compilation_unit;
118 output_string chan ".";
119 output chan t
120