Refactor the Var module to use saner names.

compile/compile.ml

@@ -16,7 +16,7 @@ let pp_vars ppf vars =
   Ident.pp_env pp_item ppf vars
 
 let pp_xi ppf xi =
-  let pp_item ppf (s,t) = Format.fprintf ppf "%s : %a" s Var.Set.pp t in
+  let pp_item ppf (s,t) = Format.fprintf ppf "%s : %a" s Var.Set.print t in
   Ident.pp_idmap pp_item ppf xi
 
 let pp_env ppf env = 

types/type_tallying.ml

@@ -8,8 +8,8 @@ let cap_product any_left any_right l =
     (any_left,any_right)
     l
 type constr =
-  |Pos of (Var.var * Types.t) (** alpha <= t | alpha \in P *)
-  |Neg of (Types.t * Var.var) (** t <= alpha | alpha \in N *)
+  |Pos of (Var.t * Types.t) (** alpha <= t | alpha \in P *)
+  |Neg of (Types.t * Var.t) (** t <= alpha | alpha \in N *)
 
 exception UnSatConstr of string
 
@@ -28,7 +28,7 @@ module CS = struct
   module M = struct
 
     module Key = struct
-      type t = Var.var
+      type t = Var.t
       let compare v1 v2 = Var.compare v1 v2
     end
     type key = Key.t
@@ -52,7 +52,7 @@ module CS = struct
 
     let pp ppf map =
       Utils.pp_list ~delim:("{","}") (fun ppf (v, (i,s)) ->
-        Format.fprintf ppf "%a <= %a <= %a" Print.pp_type i Var.pp v Print.pp_type s
+        Format.fprintf ppf "%a <= %a <= %a" Print.pp_type i Var.print v Print.pp_type s
       ) ppf (VarMap.bindings map)
 
     let compare map1 map2 =
@@ -83,13 +83,13 @@ module CS = struct
        { alpha -> ((s v beta) ^ t) } with beta fresh *)
   module E = struct
     include Map.Make(struct
-      type t = Var.var
+      type t = Var.t
       let compare = Var.compare
     end)
 
     let pp ppf e =
       Utils.pp_list ~delim:("{","}") (fun ppf -> fun (v,t) ->
-        Format.fprintf ppf "%a = %a@," Var.pp v Print.pp_type t
+        Format.fprintf ppf "%a = %a@," Var.print v Print.pp_type t
       ) ppf (bindings e)
 
   end
@@ -548,7 +548,7 @@ let solve delta s =
   let aux alpha (s,t) acc =
       (* we cannot solve twice the same variable *)
     assert(not(CS.E.mem alpha acc));
-    let v = Var.mk (Printf.sprintf "#fr_%s" (Var.id alpha)) in
+    let v = Var.mk ~internal:true (Printf.sprintf "#%s" (Var.ident alpha)) in
     let b = var v in
       (* s <= alpha <= t --> alpha = ( s v fresh ) ^ t *)
     CS.E.add alpha (cap (cup s b) t) acc
@@ -581,14 +581,14 @@ let unify e =
     if CS.E.is_empty e then sol
     else begin
       let (alpha,t) = CS.E.min_binding e in
-        (* Format.printf "Unify -> %a = %a\n" Var.pp alpha Print.pp_type t; *)
+        (* Format.printf "Unify -> %a = %a\n" Var.print alpha Print.pp_type t; *)
       let e1 = CS.E.remove alpha e in
         (* Format.printf "e1 = %a\n" CS.print_e e1; *)
         (* remove from E \ { (alpha,t) } every occurrences of alpha
          * by mu X . (t{X/alpha}) with X fresh . X is a recursion variale *)
         (* solve_rectype remove also all previously introduced fresh variables *)
       let x = Substitution.solve_rectype t alpha in
-        (* Format.printf "X = %a %a %a\n" Var.pp alpha Print.print x dump t; *)
+        (* Format.printf "X = %a %a %a\n" Var.print alpha Print.print x dump t; *)
       let es =
         CS.E.fold (fun beta s acc ->
           CS.E.add beta (Substitution.single s (alpha,x)) acc

types/type_tallying.mli

 open Types
 
 type constr =
-  | Pos of (Var.var * t) (** alpha <= t | alpha \in P *)
-  | Neg of (t * Var.var) (** t <= alpha | alpha \in N *)
+  | Pos of (Var.t * t) (** alpha <= t | alpha \in P *)
+  | Neg of (t * Var.t) (** t <= alpha | alpha \in N *)
 
 exception UnSatConstr of string
 exception Step1Fail
@@ -10,7 +10,7 @@ exception Step2Fail
 
 module CS : sig
   module M : sig
-    type key = Var.var
+    type key = Var.t
     type t
     val compare  : t -> t -> int
     val empty : t
@@ -20,7 +20,7 @@ module CS : sig
     val inter : Var.Set.t -> t -> t -> t
   end
   module E : sig
-    include Map.S with type key = Var.var
+    include Map.S with type key = Var.t
     val pp : Format.formatter -> descr t -> unit
   end
   module ES : sig

types/types.mli

@@ -139,7 +139,7 @@ val non_constructed_or_absent : t
 
 type pair_kind = [ `Normal | `XML ]
 
-val var      : Var.var -> t
+val var      : Var.t -> t
 val interval : Intervals.t -> t
 val atom     : Atoms.t -> t
 val times    : Node.t -> Node.t -> t
@@ -185,16 +185,15 @@ module Positive : sig
 end
 
 module Variable : sig
-    val extract : t -> Var.var * bool
+    val extract : t -> Var.t * bool
 end
 
 module Substitution : sig
-  val full : t -> (Var.var * t) list -> t
-  val single : t -> (Var.var * t) -> t
+  val full : t -> (Var.t * t) list -> t
+  val single : t -> (Var.t * t) -> t
   val freshen : Var.Set.t -> t -> t
   val hide_vars : t -> t
-  val solve_rectype : t -> Var.var -> t
-  val kind : Var.Set.t -> Var.kind -> t -> t
+  val solve_rectype : t -> Var.t -> t
   val clean_type : Var.Set.t -> t -> t
 end
 
@@ -365,7 +364,7 @@ val cond_partition: t -> (t * t) list -> t list
      to answer all the questions. *)
 
 module Print : sig
-  type gname = string * Ns.QName.t * (Var.var * t) list
+  type gname = string * Ns.QName.t * (Var.t * t) list
   val register_global : gname -> t -> unit
   val pp_const : Format.formatter -> const -> unit
   val pp_type: Format.formatter -> t -> unit

types/var.ml

 module V = struct
-  type t = { id : Ident.U.t ; fr : int ; kind : int }
-  type kind = int
-  let function_kind = 1
-  let argument_kind = 2
 
-  let dump ppf t = Format.fprintf ppf "%a(%d_%d)" Ident.U.print t.id t.fr t.kind
-  let compare x y = Pervasives.compare (x.kind,x.id,x.fr) (y.kind,y.id,y.fr)
+
+  type kind = Source | Internal
+
+  type t = { name : Ident.U.t ;
+	     id : int ;
+	     kind : kind }
+
+  let print_kind ppf k = Format.fprintf ppf "%s"
+    (match k with Source -> "Source" | Internal -> "Internal")
+
+  let compare_kind k1 k2 = if k1 == k2 then 0 else if k1 < k2 then -1 else 1
+
+  let dump ppf t =
+    Format.fprintf ppf "%a(%d_%a)" Ident.U.print t.name t.id print_kind t.kind
+
+  let compare x y =
+    let c = compare_kind x.kind y.kind in
+    if c == 0 then
+      let c = Pervasives.compare x.id y.id in
+      if c == 0 then Ident.U.compare x.name y.name
+      else c
+    else c
+
   let equal x y =
-    x == y || (x.kind == y.kind && x.fr == y.fr && Ident.U.equal x.id y.id)
-  let hash x = Hashtbl.hash (x.id,x.fr,x.kind)
-  let check _ = ()
+    x == y || (x.kind == y.kind && x.id == y.id && Ident.U.equal x.name y.name)
 
-  let freshcounter = ref 0
+  let hash x = Hashtbl.hash (x.id,x.name,x.kind)
 
-  let is_fresh x = x.fr > 0
+  let check x = assert (x.id >= 0)
 
-  let fresh v = { v with fr = (incr freshcounter;!freshcounter) }
+  let refresh v =
+    (* according to Alain, a thread safe way to generate a unique ID *)
+    { v with id = Oo.id (object end) }
 
-  let mk id = { id = Ident.U.mk id; fr = 0; kind = 0; }
+  let mk ?(internal=false) id = { name = Ident.U.mk id;
+				  id = 0;
+				  kind = if internal then Internal else Source;
+				}
+  let is_internal x = x.kind == Internal
 
-  let id x = Ident.U.get_str x.id
-  let set_kind k v = { v with kind = k }
-  let pp ppf x = Format.fprintf ppf "'%a" Ident.U.print x.id
+  let ident x = Ident.U.get_str x.name
+  let print ppf x = Format.fprintf ppf "'%a" Ident.U.print x.name
 end
 
-include V
-type var = t
+
 
 module Set = struct
   include SortedList.Make(V)
   let dump ppf s = Utils.pp_list ~sep:";" ~delim:("{","}") V.dump ppf (get s)
-  let pp ppf s = Utils.pp_list ~sep:";" ~delim:("{","}") V.pp ppf (get s)
-  let printf = pp Format.std_formatter
+  let print ppf s = Utils.pp_list ~sep:";" ~delim:("{","}") V.print ppf (get s)
 end
 
+
+include V
+let gen set =
+  let idx = ref 0 in
+  let rec freshvar () =
+    let rec pretty i acc =
+      let ni,nm = i/26, i mod 26 in
+      let acc = acc ^
+        (String.make 1 (Char.chr (Char.code 'a' + nm)))
+      in
+      if ni == 0 then acc else pretty ni acc
+    in
+    let x = mk (pretty !idx "") in
+    if Set.mem set x then
+      (* if the name is taken by a variable in delta, restart *)
+      (incr idx; freshvar ())
+    else x
+  in
+  freshvar ()
+
 type 'a var_or_atom = [ `Atm of 'a | `Var of t ]
 
 module Make (X : Custom.T) = struct
@@ -55,3 +93,4 @@ module Make (X : Custom.T) = struct
     |`Atm x -> X.dump ppf x
     |`Var x -> V.dump ppf x
 end
+

types/var.mli

-
 include Custom.T
-type kind
 
-type var = t
+val print : Format.formatter -> t -> unit
+val mk : ?internal:bool -> string -> t
+val ident : t -> string
+val refresh : t -> t
 
-val function_kind : kind
-val argument_kind : kind
-val set_kind : kind -> t -> t
-val pp : Format.formatter -> t -> unit
-val mk : string -> t
-val id : t -> string
-val fresh : t -> t
-(*
-val is_fresh : t -> bool
-val is_internal : t -> bool
-*)
 
 module Set : sig
-  include SortedList.S with type Elem.t = var
-  val pp : Format.formatter -> t -> unit
+  include SortedList.S with type Elem.t = t
+  val print : Format.formatter -> t -> unit
   val dump : Format.formatter -> t -> unit
 end
 
+val gen : Set.t -> t
+
 type 'a var_or_atom = [ `Atm of 'a | `Var of t ]
 
 module Make (X : Custom.T) : Custom.T with type t = X.t var_or_atom

typing/typed.ml

@@ -187,7 +187,7 @@ module Print = struct
   and pp_fv ppf fv = Utils.pp_list pp_v ppf (IdSet.get fv)
 
   and pp_vars_poly ppf m =
-    let pp_aux ppf (x,s) = Format.fprintf ppf "%a : %a" Ident.print x  Var.Set.pp s in
+    let pp_aux ppf (x,s) = Format.fprintf ppf "%a : %a" Ident.print x  Var.Set.print s in
     Utils.pp_list ~sep:";" pp_aux ppf (Ident.IdMap.get m)
 
   let string_of_typed = Utils.string_of_formatter pp

typing/typer.ml

@@ -54,7 +54,7 @@ let pp_env ppf env =
     |Type (t,[]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
     |Type (t,al) ->
       Format.fprintf ppf "type %s(%a) = %a" s
-        (Utils.pp_list ~delim:("","") Var.pp) al
+        (Utils.pp_list ~delim:("","") Var.print) al
         Types.Print.pp_noname t
     |_ -> ()
   in
@@ -72,7 +72,7 @@ let pp_env ppf env =
   in
   Format.printf "{ids=%a;delta=%a}"
     (Ident.pp_env pp_item) ids
-    Var.Set.pp env.delta
+    Var.Set.print env.delta
 ;;
 
 (* Namespaces *)
@@ -390,7 +390,7 @@ module IType = struct
   type penv = {
     penv_tenv : t;
     penv_derec : (node * U.t list) Env.t;
-    penv_var : (string, Var.var) Hashtbl.t;
+    penv_var : (string, Var.t) Hashtbl.t;
   }
 
   let penv tenv = { penv_tenv = tenv; penv_derec = Env.empty ; penv_var = Hashtbl.create 17 }
@@ -454,7 +454,7 @@ module IType = struct
       [], [] -> true
     | v :: vll, { descr = Internal (p); _ } :: pll ->
       Types.is_var p
-      && (U.equal v (U.mk(Var.(id (Set.choose (Types.all_vars p))))))
+      && (U.equal v (U.mk(Var.(ident (Set.choose (Types.all_vars p))))))
       && comp_var_pat vll pll
     | _ -> false
 
@@ -619,7 +619,7 @@ module IType = struct
             (Printf.sprintf "Definition of type %s contains unbound type variables"
                (Ident.to_string v));
         let vars_mapping = (* create a sequence 'a -> 'a_0 for all variables *)
-          List.map (fun v -> let vv =  Var.mk (U.to_string v) in vv, Var.fresh vv) args
+          List.map (fun v -> let vv =  Var.mk (U.to_string v) in vv, Var.refresh vv) args
         in
         let sub_list = List.map (fun (v,vt) -> v, Types.var vt) vars_mapping in
         let t_rhs =