Commit b17ef0fc authored by Kim Nguyễn's avatar Kim Nguyễn

Refactor the Var module to use saner names.

parent d53ca3c7
......@@ -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 =
......
......@@ -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
......
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
......
This diff is collapsed.
......@@ -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
......
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
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
......@@ -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
......
......@@ -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 =
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment