package / ocaml-base-compiler.4.10.0 / middle_end / compilation_unit.ml
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 id : Ident.t;
22 linkage_name : Linkage_name.t;
23 hash : int;
24 }
25
26 let string_for_printing t = Ident.name t.id
27
28 include Identifiable.Make (struct
29 type nonrec t = t
30
31 (* Multiple units can have the same [id] if they come from different packs.
32 To distinguish these we also keep the linkage name, which contains the
33 name of the pack. *)
34 let compare v1 v2 =
35 if v1 == v2 then 0
36 else
37 let c = compare v1.hash v2.hash in
38 if c = 0 then
39 let v1_id = Ident.name v1.id in
40 let v2_id = Ident.name v2.id in
41 let c = String.compare v1_id v2_id in
42 if c = 0 then
43 Linkage_name.compare v1.linkage_name v2.linkage_name
44 else
45 c
46 else c
47
48 let equal x y =
49 if x == y then true
50 else compare x y = 0
51
52 let print ppf t = Format.pp_print_string ppf (string_for_printing t)
53
54 let output oc x = output_string oc (Ident.name x.id)
55 let hash x = x.hash
56 end)
57
58 let create (id : Ident.t) linkage_name =
59 if not (Ident.persistent id) then begin
60 Misc.fatal_error "Compilation_unit.create with non-persistent Ident.t"
61 end;
62 { id; linkage_name; hash = Hashtbl.hash (Ident.name id); }
63
64 let get_persistent_ident cu = cu.id
65 let get_linkage_name cu = cu.linkage_name
66
67 let current = ref None
68 let is_current arg =
69 match !current with
70 | None -> Misc.fatal_error "Current compilation unit is not set!"
71 | Some cur -> equal cur arg
72 let set_current t = current := Some t
73 let get_current () = !current
74 let get_current_exn () =
75 match !current with
76 | Some current -> current
77 | None -> Misc.fatal_error "Compilation_unit.get_current_exn"
78 let get_current_id_exn () = get_persistent_ident (get_current_exn ())
79