Commit ea80ff58 authored by Pietro Abate's avatar Pietro Abate

Add delta to Positive.clean_type and Tallying.norm

parent ec80900d
......@@ -39,8 +39,8 @@ and vv = V of string
let mk_s ll =
let aux l =
List.fold_left (fun acc -> function
|P(V alpha,t) -> Tallying.CS.M.add ((*true,*)Var.mk alpha) (Types.empty,parse_typ t) acc
|N(t,V alpha) -> Tallying.CS.M.add ((*false,*)Var.mk alpha) (parse_typ t,Types.any) acc
|P(V alpha,t) -> Tallying.CS.M.add Var.Set.empty (Var.mk alpha) (Types.empty,parse_typ t) acc
|N(t,V alpha) -> Tallying.CS.M.add Var.Set.empty (Var.mk alpha) (parse_typ t,Types.any) acc
) Tallying.CS.M.empty l
in
List.fold_left (fun acc l ->
......@@ -50,8 +50,8 @@ let mk_s ll =
let mk_union_res l1 l2 =
let aux l =
List.fold_left (fun acc -> function
|P(V v,s) -> Tallying.CS.M.merge acc (Tallying.CS.M.singleton (Var.mk v) (Types.empty, parse_typ s))
|N(s,V v) -> Tallying.CS.M.merge acc (Tallying.CS.M.singleton (Var.mk v) (parse_typ s, Types.any))
|P(V v,s) -> Tallying.CS.M.inter Var.Set.empty acc (Tallying.CS.M.singleton (Var.mk v) (Types.empty, parse_typ s))
|N(s,V v) -> Tallying.CS.M.inter Var.Set.empty acc (Tallying.CS.M.singleton (Var.mk v) (parse_typ s, Types.any))
) Tallying.CS.M.empty l
in
match l1,l2 with
......@@ -62,12 +62,12 @@ let mk_union_res l1 l2 =
(* check invariants on the constraints sets *)
let mk_pp = function
|P(V alpha,t) -> Tallying.CS.singleton (Tallying.Pos (Var.mk alpha,parse_typ t))
|N(t,V alpha) -> Tallying.CS.singleton (Tallying.Neg (parse_typ t,Var.mk alpha))
|P(V alpha,t) -> Tallying.CS.singleton Var.Set.empty (Tallying.Pos (Var.mk alpha,parse_typ t))
|N(t,V alpha) -> Tallying.CS.singleton Var.Set.empty (Tallying.Neg (parse_typ t,Var.mk alpha))
let mk_prod l =
List.fold_left (fun acc c ->
Tallying.CS.prod (mk_pp c) acc
Tallying.CS.prod Var.Set.empty (mk_pp c) acc
) Tallying.CS.sat l
let mk_union l1 l2 =
......
module type E = sig
type elem
include Custom.T
val empty : t
val full : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
end
module type S = sig
type s
type elem = s Var.pairvar
include Custom.T
(** returns the union of all leaves in the BDD *)
val leafconj: t -> s
val get: t -> (elem list * elem list) list
val empty : t
val full : t
(* same as full, but we keep it for the moment to avoid chaging the code everywhere *)
val any : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
val trivially_disjoint: t -> t -> bool
(** vars a : return a bdd that is ( Any ^ Var a ) *)
val vars : Var.var -> t
val iter: (elem-> unit) -> t -> unit
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:(elem -> 'b) -> t -> 'b
val is_empty : t -> bool
val pp_print : Format.formatter -> t -> unit
val print : ?f:(Format.formatter -> elem -> unit) -> t -> (Format.formatter -> unit) list
end
module type MAKE = functor (T : E) -> S with type s = T.t
module Make : MAKE
This diff is collapsed.
......@@ -164,11 +164,11 @@ module Positive : sig
val times: v -> v -> v
val xml: v -> v -> v
(* val decompose : t -> v *)
val substitute : t -> (Var.var * t) -> t
val substituterec : t -> Var.var -> t
val solve: v -> Node.t
val substitutefree : Var.Set.t -> t -> t
val clean_type : Var.Set.t -> t -> t
end
(** Normalization **)
......@@ -203,7 +203,6 @@ module Product : sig
val need_second: t -> bool
(* Is there more than a single rectangle ? *)
val clean_normal: t -> t
(* Merge rectangles with same second component *)
end
......@@ -383,10 +382,10 @@ module Tallying : sig
type t
val compare : t -> t -> int
val empty : t
val add : key -> descr*descr -> t -> t
val add : Var.Set.t -> key -> descr*descr -> t -> t
val singleton : key -> descr*descr -> t
val pp : Format.formatter -> t -> unit
val merge : t -> t -> t
val inter : Var.Set.t -> t -> t -> t
end
module E : sig
include Map.S with type key = Var.var
......@@ -418,12 +417,12 @@ module Tallying : sig
val pp_e : Format.formatter -> sigma -> unit
val pp_sl : Format.formatter -> sl -> unit
val merge : m -> m -> m
val singleton : constr -> s
(* val merge : m -> m -> m *)
val singleton : Var.Set.t -> constr -> s
val sat : s
val unsat : s
val union : s -> s -> s
val prod : s -> s -> s
val prod : Var.Set.t -> s -> s -> s
end
val norm : Var.Set.t -> t -> CS.s
......@@ -458,7 +457,7 @@ end
(** Square Subtype relation. [squaresubtype delta s t] .
True if there exists a substitution such that s < t only
considering variables that are not in delta *)
val squaresubtype : Var.Set.t -> t -> t -> (Tallying.CS.sl * bool)
val squaresubtype : Var.Set.t -> t -> t -> Tallying.CS.sl
val is_squaresubtype : Var.Set.t -> t -> t -> bool
(** apply_raw s t returns the 4-tuple (subst,ss, tt, res) where
......
......@@ -912,7 +912,7 @@ and type_check' loc env ed constr precise = match ed with
if not (Types.subtype t1 acc) then
raise_loc loc (NonExhaustive (Types.diff t1 acc));
let t = type_check_branches loc env t1 a.fun_body t2 false in
(fst(Types.squaresubtype env.delta t t2))::tacc (* H_j *)
(Types.squaresubtype env.delta t t2)::tacc (* H_j *)
) [] a.fun_iface
in
List.iter (fun sl ->
......
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