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"] 18 19module type BaseId = sig 20 type t 21 val equal : t -> t -> bool 22 val compare : t -> t -> int 23 val hash : t -> int 24 val name : t -> string option 25 val to_string : t -> string 26 val output : out_channel -> t -> unit 27 val print : Format.formatter -> t -> unit 28end 29 30module type Id = sig 31 include BaseId 32 val create : ?name:string -> unit -> t 33end 34 35module type UnitId = sig 36 module Compilation_unit : Identifiable.Thing 37 include BaseId 38 val create : ?name:string -> Compilation_unit.t -> t 39 val unit : t -> Compilation_unit.t 40end 41 42module Id(E:sig end) : Id = struct 43 type t = int * string 44 let empty_string = "" 45 let create = let r = ref 0 in 46 fun ?(name=empty_string) () -> incr r; !r, name 47 let equal (t1,_) (t2,_) = (t1:int) = t2 48 let compare (t1,_) (t2,_) = t1 - t2 49 let hash (t,_) = t 50 let name (_,name) = 51 if name == empty_string 52 then None 53 else Some name 54 let to_string (t,name) = 55 if name == empty_string 56 then string_of_int t 57 else Printf.sprintf "%s_%i" name t 58 let output fd t = output_string fd (to_string t) 59 let print ppf v = Format.pp_print_string ppf (to_string v) 60end 61 62module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) : 63 UnitId with module Compilation_unit := Compilation_unit = struct 64 type t = { 65 id : Innerid.t; 66 unit : Compilation_unit.t; 67 } 68 let compare x y = 69 let c = Innerid.compare x.id y.id in 70 if c <> 0 71 then c 72 else Compilation_unit.compare x.unit y.unit 73 let output oc x = 74 Printf.fprintf oc "%a.%a" 75 Compilation_unit.output x.unit 76 Innerid.output x.id 77 let print ppf x = 78 Format.fprintf ppf "%a.%a" 79 Compilation_unit.print x.unit 80 Innerid.print x.id 81 let hash off = Hashtbl.hash off 82 let equal o1 o2 = compare o1 o2 = 0 83 let name o = Innerid.name o.id 84 let to_string x = 85 Format.asprintf "%a.%a" 86 Compilation_unit.print x.unit 87 Innerid.print x.id 88 let create ?name unit = 89 let id = Innerid.create ?name () in 90 { id; unit } 91 let unit x = x.unit 92end 93