Commit 9da1d67c authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Add a workaround in case pattern compilation failed (after typechecking) due...

Add a workaround in case pattern compilation failed (after typechecking) due to the presence of type variables in some types.
parent cd7eaf51
...@@ -39,18 +39,18 @@ let accept x = Types.internalize x.accept ...@@ -39,18 +39,18 @@ let accept x = Types.internalize x.accept
let printed = ref [] let printed = ref []
let to_print = ref [] let to_print = ref []
let rec print ppf (a,_,d) = let rec print ppf (a,_,d) =
match d with match d with
| Constr t -> Types.Print.pp_type ppf t | Constr t -> Types.Print.pp_type ppf t
| Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2 | Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
| Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2 | Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
| Times (n1,n2) -> | Times (n1,n2) ->
Format.fprintf ppf "(P%i,P%i)" n1.id n2.id; Format.fprintf ppf "(P%i,P%i)" n1.id n2.id;
to_print := n1 :: n2 :: !to_print to_print := n1 :: n2 :: !to_print
| Xml (n1,n2) -> | Xml (n1,n2) ->
Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id; Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
to_print := n1 :: n2 :: !to_print to_print := n1 :: n2 :: !to_print
| Record (l,n) -> | Record (l,n) ->
Format.fprintf ppf "{ %a = P%i }" Label.print_attr l n.id; Format.fprintf ppf "{ %a = P%i }" Label.print_attr l n.id;
to_print := n :: !to_print to_print := n :: !to_print
| Capture x -> | Capture x ->
...@@ -111,31 +111,31 @@ let cons fv d = ...@@ -111,31 +111,31 @@ let cons fv d =
q q
let constr x = (x,IdSet.empty,Constr x) let constr x = (x,IdSet.empty,Constr x)
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
if not (IdSet.equal fv1 fv2) then ( if not (IdSet.equal fv1 fv2) then (
let x = match IdSet.pick (IdSet.diff fv1 fv2) with let x = match IdSet.pick (IdSet.diff fv1 fv2) with
| Some x -> x | Some x -> x
| None -> get_opt (IdSet.pick (IdSet.diff fv2 fv1)) | None -> get_opt (IdSet.pick (IdSet.diff fv2 fv1))
in in
raise raise
(Error (Error
("The capture variable " ^ (Ident.to_string x) ^ ("The capture variable " ^ (Ident.to_string x) ^
" should appear on both side of this | pattern")) " should appear on both side of this | pattern"))
); );
(Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2)) (Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) =
if not (IdSet.disjoint fv1 fv2) then ( if not (IdSet.disjoint fv1 fv2) then (
let x = get_opt (IdSet.pick (IdSet.cap fv1 fv2)) in let x = get_opt (IdSet.pick (IdSet.cap fv1 fv2)) in
raise raise
(Error (Error
("The capture variable " ^ (Ident.to_string x) ^ ("The capture variable " ^ (Ident.to_string x) ^
" cannot appear on both side of this & pattern"))); " cannot appear on both side of this & pattern")));
(Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2)) (Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2))
let times x y = let times x y =
(Types.times x.accept y.accept, IdSet.cup x.fv y.fv, Times (x,y)) (Types.times x.accept y.accept, IdSet.cup x.fv y.fv, Times (x,y))
let xml x y = let xml x y =
(Types.xml x.accept y.accept, IdSet.cup x.fv y.fv, Xml (x,y)) (Types.xml x.accept y.accept, IdSet.cup x.fv y.fv, Xml (x,y))
let record l x = let record l x =
(Types.record l x.accept, x.fv, Record (l,x)) (Types.record l x.accept, x.fv, Record (l,x))
let capture x = (Types.any, IdSet.singleton x, Capture x) let capture x = (Types.any, IdSet.singleton x, Capture x)
let constant x c = (Types.any, IdSet.singleton x, Constant (x,c)) let constant x c = (Types.any, IdSet.singleton x, Constant (x,c))
...@@ -163,7 +163,7 @@ module Pat = struct ...@@ -163,7 +163,7 @@ module Pat = struct
| Constr _, _ -> -1 | _, Constr _ -> 1 | Constr _, _ -> -1 | _, Constr _ -> 1
| Cup (x1,y1), Cup (x2,y2) | Cap (x1,y1), Cap (x2,y2) -> | Cup (x1,y1), Cup (x2,y2) | Cap (x1,y1), Cap (x2,y2) ->
let c = compare x1 x2 in if c <> 0 then c let c = compare x1 x2 in if c <> 0 then c
else compare y1 y2 else compare y1 y2
| Cup _, _ -> -1 | _, Cup _ -> 1 | Cup _, _ -> -1 | _, Cup _ -> 1
| Cap _, _ -> -1 | _, Cap _ -> 1 | Cap _, _ -> -1 | _, Cap _ -> 1
...@@ -222,7 +222,7 @@ module Print = struct ...@@ -222,7 +222,7 @@ module Print = struct
(incr id; (incr id;
names := M.add p !id !names; names := M.add p !id !names;
Queue.add p toprint) Queue.add p toprint)
else else
let seen = S.add p seen in let seen = S.add p seen in
match d with match d with
| Cup (p1,p2) | Cap (p1,p2) -> mark seen p1; mark seen p2 | Cup (p1,p2) | Cap (p1,p2) -> mark seen p1; mark seen p2
...@@ -231,7 +231,7 @@ module Print = struct ...@@ -231,7 +231,7 @@ module Print = struct
| _ -> () | _ -> ()
let rec print ppf p = let rec print ppf p =
try try
let i = M.find p !names in let i = M.find p !names in
Format.fprintf ppf "P%i" i Format.fprintf ppf "P%i" i
with Not_found -> with Not_found ->
...@@ -255,14 +255,14 @@ module Print = struct ...@@ -255,14 +255,14 @@ module Print = struct
| Constant (x,c) -> | Constant (x,c) ->
Format.fprintf ppf "(%a:=%a)" Ident.print x Types.Print.pp_const c Format.fprintf ppf "(%a:=%a)" Ident.print x Types.Print.pp_const c
| Dummy -> assert false | Dummy -> assert false
let pp ppf p = let pp ppf p =
mark S.empty p; mark S.empty p;
print ppf p; print ppf p;
let first = ref true in let first = ref true in
(try while true do (try while true do
let p = Queue.pop toprint in let p = Queue.pop toprint in
if not (S.mem p !printed) then if not (S.mem p !printed) then
( printed := S.add p !printed; ( printed := S.add p !printed;
Format.fprintf ppf " %s@ @[%a=%a@]" Format.fprintf ppf " %s@ @[%a=%a@]"
(if !first then (first := false; "where") else "and") (if !first then (first := false; "where") else "and")
...@@ -298,10 +298,10 @@ let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv ...@@ -298,10 +298,10 @@ let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
let times_res v1 v2 = Types.Positive.times v1 v2 let times_res v1 v2 = Types.Positive.times v1 v2
(* Try with a hash-table *) (* Try with a hash-table *)
module MemoFilter = Map.Make module MemoFilter = Map.Make
(struct (struct
type t = Types.t * node type t = Types.t * node
let compare (t1,n1) (t2,n2) = let compare (t1,n1) (t2,n2) =
if n1.id < n2.id then -1 else if n1.id > n2.id then 1 else if n1.id < n2.id then -1 else if n1.id > n2.id then 1 else
Types.compare t1 t2 Types.compare t1 t2
end) end)
...@@ -314,7 +314,7 @@ let rec filter_descr t (_,fv,d) : Types.Positive.v id_map = ...@@ -314,7 +314,7 @@ let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
else else
match d with match d with
| Constr t0 -> | Constr t0 ->
if Types.subtype t t0 then IdMap.empty if Types.subtype t t0 then IdMap.empty
else (empty_res fv) (* omega *) else (empty_res fv) (* omega *)
| Cup ((a,_,_) as d1,d2) -> | Cup ((a,_,_) as d1,d2) ->
IdMap.merge cup_res IdMap.merge cup_res
...@@ -333,9 +333,9 @@ let rec filter_descr t (_,fv,d) : Types.Positive.v id_map = ...@@ -333,9 +333,9 @@ let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
| Dummy -> assert false | Dummy -> assert false
and filter_prod ?kind fv p1 p2 t = and filter_prod ?kind fv p1 p2 t =
List.fold_left List.fold_left
(fun accu (d1,d2) -> (fun accu (d1,d2) ->
let term = let term =
IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2) IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
in in
IdMap.merge cup_res accu term IdMap.merge cup_res accu term
...@@ -377,20 +377,20 @@ module Factorize = struct ...@@ -377,20 +377,20 @@ module Factorize = struct
x=(1,2) x=(1,2)
*) *)
let rec approx_var seen (a,fv,d) t xs = let rec approx_var seen (a,fv,d) t xs =
(* assert (Types.subtype t a); (* assert (Types.subtype t a);
assert (IdSet.subset xs fv); *) assert (IdSet.subset xs fv); *)
if (IdSet.is_empty xs) || (Types.is_empty t) then xs if (IdSet.is_empty xs) || (Types.is_empty t) then xs
else match d with else match d with
| Cup ((a1,_,_) as p1,p2) -> | Cup ((a1,_,_) as p1,p2) ->
approx_var seen p2 (Types.diff t a1) approx_var seen p2 (Types.diff t a1)
(approx_var seen p1 (Types.cap t a1) xs) (approx_var seen p1 (Types.cap t a1) xs)
| Cap ((_,fv1,_) as p1,((_,fv2,_) as p2)) -> | Cap ((_,fv1,_) as p1,((_,fv2,_) as p2)) ->
IdSet.cup IdSet.cup
(approx_var seen p1 t (IdSet.cap fv1 xs)) (approx_var seen p1 t (IdSet.cap fv1 xs))
(approx_var seen p2 t (IdSet.cap fv2 xs)) (approx_var seen p2 t (IdSet.cap fv2 xs))
| Capture _ -> | Capture _ ->
xs xs
| Constant (_,c) -> | Constant (_,c) ->
if (Types.subtype t (Types.constant c)) then xs else IdSet.empty if (Types.subtype t (Types.constant c)) then xs else IdSet.empty
| Times (q1,q2) -> | Times (q1,q2) ->
let xs = IdSet.cap xs (IdSet.cap q1.fv q2.fv) in let xs = IdSet.cap xs (IdSet.cap q1.fv q2.fv) in
...@@ -404,22 +404,22 @@ x=(1,2) ...@@ -404,22 +404,22 @@ x=(1,2)
(approx_var_node seen q2 (pi2 ~kind:`XML t) xs) (approx_var_node seen q2 (pi2 ~kind:`XML t) xs)
| Record _ -> IdSet.empty | Record _ -> IdSet.empty
| _ -> assert false | _ -> assert false
and approx_var_node seen q t xs = and approx_var_node seen q t xs =
if (NodeTypeSet.mem (q,t) seen) if (NodeTypeSet.mem (q,t) seen)
then xs then xs
else approx_var (NodeTypeSet.add (q,t) seen) q.descr t xs else approx_var (NodeTypeSet.add (q,t) seen) q.descr t xs
(* Obviously not complete ! *)
(* Obviously not complete ! *)
let rec approx_nil seen (a,fv,d) t xs = let rec approx_nil seen (a,fv,d) t xs =
assert (Types.subtype t a); assert (Types.subtype t a);
assert (IdSet.subset xs fv); assert (IdSet.subset xs fv);
if (IdSet.is_empty xs) || (Types.is_empty t) then xs if (IdSet.is_empty xs) || (Types.is_empty t) then xs
else match d with else match d with
| Cup ((a1,_,_) as p1,p2) -> | Cup ((a1,_,_) as p1,p2) ->
approx_nil seen p2 (Types.diff t a1) approx_nil seen p2 (Types.diff t a1)
(approx_nil seen p1 (Types.cap t a1) xs) (approx_nil seen p1 (Types.cap t a1) xs)
| Cap ((_,fv1,_) as p1,((_,fv2,_) as p2)) -> | Cap ((_,fv1,_) as p1,((_,fv2,_) as p2)) ->
IdSet.cup IdSet.cup
(approx_nil seen p1 t (IdSet.cap fv1 xs)) (approx_nil seen p1 t (IdSet.cap fv1 xs))
...@@ -429,9 +429,9 @@ x=(1,2) ...@@ -429,9 +429,9 @@ x=(1,2)
let xs = IdSet.cap q2.fv (IdSet.diff xs q1.fv) in let xs = IdSet.cap q2.fv (IdSet.diff xs q1.fv) in
approx_nil_node seen q2 (pi2 ~kind:`Normal t) xs approx_nil_node seen q2 (pi2 ~kind:`Normal t) xs
| _ -> IdSet.empty | _ -> IdSet.empty
and approx_nil_node seen q t xs = and approx_nil_node seen q t xs =
if (NodeTypeSet.mem (q,t) seen) if (NodeTypeSet.mem (q,t) seen)
then xs then xs
else approx_nil (NodeTypeSet.add (q,t) seen) q.descr t xs else approx_nil (NodeTypeSet.add (q,t) seen) q.descr t xs
...@@ -448,11 +448,11 @@ x=(1,2) ...@@ -448,11 +448,11 @@ x=(1,2)
let t = Types.cap t a in let t = Types.cap t a in
IdMap.from_list_disj (List.fold_left aux [] (filter_descr t p)) IdMap.from_list_disj (List.fold_left aux [] (filter_descr t p))
*) *)
let var ((a,_,_) as p) t = let var ((a,_,_) as p) t =
approx_var NodeTypeSet.empty p (Types.cap t a) approx_var NodeTypeSet.empty p (Types.cap t a)
let nil ((a,_,_) as p) t = let nil ((a,_,_) as p) t =
approx_nil NodeTypeSet.empty p (Types.cap t a) approx_nil NodeTypeSet.empty p (Types.cap t a)
end end
...@@ -466,7 +466,7 @@ let min (a:int) (b:int) = if a < b then a else b ...@@ -466,7 +466,7 @@ let min (a:int) (b:int) = if a < b then a else b
let any_basic = Types.Record.or_absent Types.non_constructed let any_basic = Types.Record.or_absent Types.non_constructed
let rec first_label (acc,fv,d) = let rec first_label (acc,fv,d) =
if Types.is_empty acc if Types.is_empty acc
then Label.dummy then Label.dummy
else match d with else match d with
| Constr t -> Types.Record.first_label t | Constr t -> Types.Record.first_label t
...@@ -477,11 +477,11 @@ let rec first_label (acc,fv,d) = ...@@ -477,11 +477,11 @@ let rec first_label (acc,fv,d) =
module Normal = struct module Normal = struct
type source = SCatch | SConst of Types.const type source = SCatch | SConst of Types.const
type result = source id_map type result = source id_map
let compare_source s1 s2 = let compare_source s1 s2 =
if s1 == s2 then 0 if s1 == s2 then 0
else match (s1,s2) with else match (s1,s2) with
| SCatch, _ -> -1 | _, SCatch -> 1 | SCatch, _ -> -1 | _, SCatch -> 1
| SConst c1, SConst c2 -> Types.Const.compare c1 c2 | SConst c1, SConst c2 -> Types.Const.compare c1 c2
...@@ -491,7 +491,7 @@ module Normal = struct ...@@ -491,7 +491,7 @@ module Normal = struct
| SCatch -> 1 | SCatch -> 1
| SConst c -> Types.Const.hash c | SConst c -> Types.Const.hash c
*) *)
let compare_result r1 r2 = let compare_result r1 r2 =
IdMap.compare compare_source r1 r2 IdMap.compare compare_source r1 r2
...@@ -506,19 +506,19 @@ module Normal = struct ...@@ -506,19 +506,19 @@ module Normal = struct
include Custom.Dummy include Custom.Dummy
type t = NodeSet.t * Types.t * IdSet.t (* pl,t; t <= \accept{pl} *) type t = NodeSet.t * Types.t * IdSet.t (* pl,t; t <= \accept{pl} *)
let check ((pl,t,xs) : t) = let check ((pl,t,xs) : t) =
List.iter (fun p -> assert(Types.subtype t (Types.descr p.accept))) List.iter (fun p -> assert(Types.subtype t (Types.descr p.accept)))
(pl :> Node.t list) (pl :> Node.t list)
let print ppf (pl,t,xs) = let print ppf (pl,t,xs) =
Format.fprintf ppf "@[(pl=%a;t=%a;xs=%a)@]" Format.fprintf ppf "@[(pl=%a;t=%a;xs=%a)@]"
NodeSet.dump pl Types.Print.pp_type t NodeSet.dump pl Types.Print.pp_type t
IdSet.dump xs IdSet.dump xs
let compare (l1,t1,xs1) (l2,t2,xs2) = let compare (l1,t1,xs1) (l2,t2,xs2) =
let c = NodeSet.compare l1 l2 in if c <> 0 then c let c = NodeSet.compare l1 l2 in if c <> 0 then c
else let c = Types.compare t1 t2 in if c <> 0 then c else let c = Types.compare t1 t2 in if c <> 0 then c
else IdSet.compare xs1 xs2 else IdSet.compare xs1 xs2
let hash (l,t,xs) = let hash (l,t,xs) =
(NodeSet.hash l) + 17 * (Types.hash t) + 257 * (IdSet.hash xs) (NodeSet.hash l) + 17 * (Types.hash t) + 257 * (IdSet.hash xs)
let equal x y = compare x y == 0 let equal x y = compare x y == 0
...@@ -554,24 +554,24 @@ module Normal = struct ...@@ -554,24 +554,24 @@ module Normal = struct
let fus = IdMap.union_disj let fus = IdMap.union_disj
let nempty lab = let nempty lab =
{ nprod = NLineProd.empty; { nprod = NLineProd.empty;
nxml = NLineProd.empty; nxml = NLineProd.empty;
nrecord = (match lab with nrecord = (match lab with
| Some l -> RecLabel (l,NLineProd.empty) | Some l -> RecLabel (l,NLineProd.empty)
| None -> RecNolabel (None,None)) | None -> RecNolabel (None,None))
} }
let dummy = nempty None let dummy = nempty None
let ncup nf1 nf2 = let ncup nf1 nf2 =
{ nprod = NLineProd.union nf1.nprod nf2.nprod; { nprod = NLineProd.union nf1.nprod nf2.nprod;
nxml = NLineProd.union nf1.nxml nf2.nxml; nxml = NLineProd.union nf1.nxml nf2.nxml;
nrecord = (match (nf1.nrecord,nf2.nrecord) with nrecord = (match (nf1.nrecord,nf2.nrecord) with
| RecLabel (l1,r1), RecLabel (l2,r2) -> | RecLabel (l1,r1), RecLabel (l2,r2) ->
(* assert (l1 = l2); *) (* assert (l1 = l2); *)
RecLabel (l1, NLineProd.union r1 r2) RecLabel (l1, NLineProd.union r1 r2)
| RecNolabel (x1,y1), RecNolabel (x2,y2) -> | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
RecNolabel((if x1 == None then x2 else x1), RecNolabel((if x1 == None then x2 else x1),
(if y1 == None then y2 else y1)) (if y1 == None then y2 else y1))
| _ -> assert false) | _ -> assert false)
...@@ -588,9 +588,9 @@ module Normal = struct ...@@ -588,9 +588,9 @@ module Normal = struct
if Types.is_empty t then accu else if Types.is_empty t then accu else
let s = Types.cap s1 s2 in let s = Types.cap s1 s2 in
if Types.is_empty s then accu else if Types.is_empty s then accu else
NLineProd.add (fus res1 res2, NLineProd.add (fus res1 res2,
(NodeSet.cup pl1 pl2, t, IdSet.cup xs1 xs2), (NodeSet.cup pl1 pl2, t, IdSet.cup xs1 xs2),
(NodeSet.cup ql1 ql2, s, IdSet.cup ys1 ys2)) (NodeSet.cup ql1 ql2, s, IdSet.cup ys1 ys2))
accu accu
in in
let record r1 r2 = match r1,r2 with let record r1 r2 = match r1,r2 with
...@@ -598,8 +598,8 @@ module Normal = struct ...@@ -598,8 +598,8 @@ module Normal = struct
(* assert (l1 = l2); *) (* assert (l1 = l2); *)
RecLabel(l1, double_fold_prod prod r1 r2) RecLabel(l1, double_fold_prod prod r1 r2)
| RecNolabel (x1,y1), RecNolabel (x2,y2) -> | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
let x = match x1,x2 with let x = match x1,x2 with
| Some res1, Some res2 -> Some (fus res1 res2) | Some res1, Some res2 -> Some (fus res1 res2)
| _ -> None | _ -> None
and y = match y1,y2 with and y = match y1,y2 with
| Some res1, Some res2 -> Some (fus res1 res2) | Some res1, Some res2 -> Some (fus res1 res2)
...@@ -621,18 +621,18 @@ module Normal = struct ...@@ -621,18 +621,18 @@ module Normal = struct
let single_prod src p q = NLineProd.singleton (src, p,q) let single_prod src p q = NLineProd.singleton (src, p,q)
let ntimes lab acc p q xs = let ntimes lab acc p q xs =
let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in
{ (nempty lab) with { (nempty lab) with
nprod = single_prod empty_res (nnode p xsp) (nnode q xsq) nprod = single_prod empty_res (nnode p xsp) (nnode q xsq)
} }
let nxml lab acc p q xs = let nxml lab acc p q xs =
let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in let xsp = IdSet.cap xs p.fv and xsq = IdSet.cap xs q.fv in
{ (nempty lab) with { (nempty lab) with
nxml = single_prod empty_res (nnode p xsp) (nnode q xsq) nxml = single_prod empty_res (nnode p xsp) (nnode q xsq)
} }
let nrecord (lab : Label.t option) acc (l : Label.t) p xs = let nrecord (lab : Label.t option) acc (l : Label.t) p xs =
let label = get_opt lab in let label = get_opt lab in
(* Format.fprintf (* Format.fprintf
...@@ -649,18 +649,18 @@ module Normal = struct ...@@ -649,18 +649,18 @@ module Normal = struct
let nconstr lab t = let nconstr lab t =
let aux l = let aux l =
List.fold_left (fun accu (t1,t2) -> List.fold_left (fun accu (t1,t2) ->
NLineProd.add (empty_res, nc t1,nc t2) accu) NLineProd.add (empty_res, nc t1,nc t2) accu)
NLineProd.empty l in NLineProd.empty l in
let record = match lab with let record = match lab with
| None -> | None ->
let (x,y) = Types.Record.empty_cases t in let (x,y) = Types.Record.empty_cases t in
RecNolabel ((if x then Some empty_res else None), RecNolabel ((if x then Some empty_res else None),
(if y then Some empty_res else None)) (if y then Some empty_res else None))
| Some l -> | Some l ->
RecLabel (l,aux (Types.Record.split_normal t l)) in RecLabel (l,aux (Types.Record.split_normal t l)) in
{ nprod = aux (Types.Product.clean_normal (Types.Product.normal t)); { nprod = aux (Types.Product.clean_normal (Types.Product.normal t));
nxml = nxml =
aux (Types.Product.clean_normal (Types.Product.normal ~kind:`XML t)); aux (Types.Product.clean_normal (Types.Product.normal ~kind:`XML t));
nrecord = record nrecord = record
} }
...@@ -683,9 +683,9 @@ module Normal = struct ...@@ -683,9 +683,9 @@ module Normal = struct
else match d with else match d with
| Constr t -> assert false | Constr t -> assert false
| Cap (p,q) -> ncap (nnormal lab p xs) (nnormal lab q xs) | Cap (p,q) -> ncap (nnormal lab p xs) (nnormal lab q xs)
| Cup ((acc1,_,_) as p,q) -> | Cup ((acc1,_,_) as p,q) ->
ncup ncup
(nnormal lab p xs) (nnormal lab p xs)
(ncap (nnormal lab q xs) (nconstr lab (Types.neg acc1))) (ncap (nnormal lab q xs) (nconstr lab (Types.neg acc1)))
| Times (p,q) -> ntimes lab acc p q xs | Times (p,q) -> ntimes lab acc p q xs
| Xml (p,q) -> nxml lab acc p q xs | Xml (p,q) -> nxml lab acc p q xs
...@@ -699,7 +699,7 @@ module Normal = struct ...@@ -699,7 +699,7 @@ module Normal = struct
let facto f t xs pl = let facto f t xs pl =
List.fold_left List.fold_left
(fun vs p -> IdSet.cup vs (f (descr p) t (IdSet.cap (fv p) xs))) (fun vs p -> IdSet.cup vs (f (descr p) t (IdSet.cap (fv p) xs)))
IdSet.empty IdSet.empty
pl pl
...@@ -713,10 +713,10 @@ module Normal = struct ...@@ -713,10 +713,10 @@ module Normal = struct
(vs_var,vs_nil,(pl,t,xs)) (vs_var,vs_nil,(pl,t,xs))
let normal l t pl xs = let normal l t pl xs =
List.fold_left List.fold_left
(fun a p -> ncap a (nnormal l (descr p) xs)) (nconstr l t) pl (fun a p -> ncap a (nnormal l (descr p) xs)) (nconstr l t) pl