Skip to content

GitLab

Commit cd44cecf authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-06-13 20:47:31 by afrisch] Cleanup 

Original author: afrisch
Date: 2005-06-13 20:47:31+00:00
parent 79bec74f
Hide whitespace changes
Inline Side-by-side
types/patterns.ml
View file @ cd44cecf
......@@ -587,15 +587,6 @@ module Normal = struct
let compare_result r1 r2 =
IdMap.compare compare_source r1 r2
let hash_result r =
IdMap.hash hash_source r
let print_result ppf r = Format.fprintf ppf "<result>"
let print_result_option ppf = function
| Some x -> Format.fprintf ppf "Some(%a)" print_result x
| None -> Format.fprintf ppf "None"
module NodeSet = SortedList.Make(Node)
module Nnf = struct
......@@ -625,99 +616,39 @@ module Normal = struct
end
module NBasic = struct
include Custom.Dummy
let serialize s _ = failwith "Patterns.NLineBasic.serialize"
type t = result * Types.t
let compare (r1,t1) (r2,t2) =
let c = compare_result r1 r2 in if c <> 0 then c
else Types.compare t1 t2
let equal x y = compare x y == 0
let hash (r,t) = hash_result r + 17 * Types.hash t
end
module NProd = struct
type t = result * Nnf.t * Nnf.t
let serialize s _ = failwith "Patterns.NLineProd.serialize"
let deserialize s = failwith "Patterns.NLineProd.deserialize"
let check x = ()
let dump ppf (r,x,y) =
Format.fprintf ppf "@[(result=%a;x=%a;y=%a)@]"
print_result r Nnf.print x Nnf.print y
let compare (r1,x1,y1) (r2,x2,y2) =
let c = compare_result r1 r2 in if c <> 0 then c
else let c = Nnf.compare x1 x2 in if c <> 0 then c
else Nnf.compare y1 y2
let equal x y = compare x y == 0
let hash (r,x,y) = hash_result r + 17 * (Nnf.hash x) + 267 * (Nnf.hash y)
end
module NLineBasic = SortedList.Make(NBasic)
module NLineProd = SortedList.Make(NProd)
module NLineBasic = Set.Make(NBasic)
module NLineProd = Set.Make(NProd)
type record =
| RecNolabel of result option * result option
| RecLabel of label * NLineProd.t
type t = {
nfv : fv;
na : Types.t;
nbasic : NLineBasic.t;
nprod : NLineProd.t;
nxml : NLineProd.t;
nrecord: record
}
let print_record ppf = function
| RecLabel (lab,l) ->
Format.fprintf ppf "RecLabel(@[%a@],@ @[%a@])"
Label.print (LabelPool.value lab)
NLineProd.dump l
| RecNolabel (a,b) ->
Format.fprintf ppf "RecNolabel(@[%a@],@[%a@])"
print_result_option a
print_result_option b
let print ppf nf =
Format.fprintf ppf "@[NF{na=%a;@ @[nprod=@ @[%a@]@]};@ @[nrecord=@ @[%a@]@]}@]"
Types.Print.print nf.na
NLineProd.dump nf.nprod
print_record nf.nrecord
include Custom.Dummy
let compare_record t1 t2 = match t1,t2 with
| RecNolabel (s1,n1), RecNolabel (s2,n2) ->
(match (s1,s2,n1,n2) with
| Some r1, Some r2, _, _ -> compare_result r1 r2
| None, Some _, _, _ -> -1
| Some _, None, _, _ -> 1
| None,None,Some r1, Some r2 -> compare_result r1 r2
| None,None,None, Some _ -> -1
| None,None, Some _, None -> 1
| None,None, None, None -> 0)
| RecNolabel (_,_), _ -> -1
| _, RecNolabel (_,_) -> 1
| RecLabel (l1,p1), RecLabel (l2,p2) ->
let c = LabelPool.compare l1 l2 in if c <> 0 then c
else NLineProd.compare p1 p2
let compare t1 t2 =
if t1 == t2 then 0
else
(* TODO: reorder; remove comparison of nfv ? *)
let c = IdSet.compare t1.nfv t2.nfv in if c <> 0 then c
else let c = Types.compare t1.na t2.na in if c <> 0 then c
else let c = NLineBasic.compare t1.nbasic t2.nbasic in if c <> 0 then c
else let c = NLineProd.compare t1.nprod t2.nprod in if c <> 0 then c
else let c = NLineProd.compare t1.nxml t2.nxml in if c <> 0 then c
else compare_record t1.nrecord t2.nrecord
let fus = IdMap.union_disj
let nempty lab =
{ nfv = IdSet.empty;
na = Types.empty;
nbasic = NLineBasic.empty;
{ nbasic = NLineBasic.empty;
nprod = NLineProd.empty;
nxml = NLineProd.empty;
nrecord = (match lab with
......@@ -728,51 +659,49 @@ module Normal = struct
let ncup nf1 nf2 =
(* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
(* assert (nf1.nfv = nf2.nfv); *)
{ nfv = nf1.nfv;
na = Types.cup nf1.na nf2.na;
nbasic = NLineBasic.cup nf1.nbasic nf2.nbasic;
nprod = NLineProd.cup nf1.nprod nf2.nprod;
nxml = NLineProd.cup nf1.nxml nf2.nxml;
{ nbasic = NLineBasic.union nf1.nbasic nf2.nbasic;
nprod = NLineProd.union nf1.nprod nf2.nprod;
nxml = NLineProd.union nf1.nxml nf2.nxml;
nrecord = (match (nf1.nrecord,nf2.nrecord) with
| RecLabel (l1,r1), RecLabel (l2,r2) ->
(* assert (l1 = l2); *)
RecLabel (l1, NLineProd.cup r1 r2)
RecLabel (l1, NLineProd.union r1 r2)
| RecNolabel (x1,y1), RecNolabel (x2,y2) ->
RecNolabel((if x1 == None then x2 else x1),
(if y1 == None then y2 else y1))
| _ -> assert false)
}
let double_fold f l1 l2 =
List.fold_left
(fun accu x1 -> List.fold_left (fun accu x2 -> f accu x1 x2) accu l2)
[] l1
let double_fold_basic f l1 l2 =
NLineBasic.fold
(fun x1 accu -> NLineBasic.fold (fun x2 accu -> f accu x1 x2) l2 accu)
l1 NLineBasic.empty
let double_fold_prod f l1 l2 =
double_fold f (NLineProd.get l1) (NLineProd.get l2)
NLineProd.fold
(fun x1 accu -> NLineProd.fold (fun x2 accu -> f accu x1 x2) l2 accu)
l1 NLineProd.empty
let ncap nf1 nf2 =
let prod accu (res1,(pl1,t1,xs1),(ql1,s1,ys1)) (res2,(pl2,t2,xs2),(ql2,s2,ys2)) =
let t = Types.cap t1 t2 in
if Types.is_empty t then accu else
let s = Types.cap s1 s2 in
if Types.is_empty s then accu else
(fus res1 res2,
NLineProd.add (fus res1 res2,
(NodeSet.cup pl1 pl2, t, IdSet.cup xs1 xs2),
(NodeSet.cup ql1 ql2, s, IdSet.cup ys1 ys2))
:: accu
accu
in
let basic accu (res1,t1) (res2,t2) =
let t = Types.cap t1 t2 in
if Types.is_empty t then accu else
(fus res1 res2, t) :: accu
NLineBasic.add (fus res1 res2, t) accu
in
let record r1 r2 = match r1,r2 with
| RecLabel (l1,r1), RecLabel (l2,r2) ->
(* assert (l1 = l2); *)
RecLabel(l1, NLineProd.from_list (double_fold_prod prod r1 r2))
RecLabel(l1, double_fold_prod prod r1 r2)
| RecNolabel (x1,y1), RecNolabel (x2,y2) ->
let x = match x1,x2 with
| Some res1, Some res2 -> Some (fus res1 res2)
......@@ -783,13 +712,9 @@ module Normal = struct
RecNolabel (x,y)
| _ -> assert false
in
{ nfv = IdSet.cup nf1.nfv nf2.nfv;
na = Types.cap nf1.na nf2.na;
nbasic = NLineBasic.from_list (double_fold basic
(NLineBasic.get nf1.nbasic)
(NLineBasic.get nf2.nbasic));
nprod = NLineProd.from_list (double_fold_prod prod nf1.nprod nf2.nprod);
nxml = NLineProd.from_list (double_fold_prod prod nf1.nxml nf2.nxml);
{ nbasic = double_fold_basic basic nf1.nbasic nf2.nbasic;
nprod = double_fold_prod prod nf1.nprod nf2.nprod;
nxml = double_fold_prod prod nf1.nxml nf2.nxml;
nrecord = record nf1.nrecord nf2.nrecord;
}
......@@ -809,8 +734,6 @@ module Normal = struct
and src_q = IdMap.constant SRight xsq in
let src = IdMap.merge_elem SRecompose src_p src_q in
{ (nempty lab) with
nfv = xs;
na = acc;
nprod = single_prod src (nnode p xsp) (nnode q xsq)
}
......@@ -820,8 +743,6 @@ module Normal = struct
and src_q = IdMap.constant SRight xsq in
let src = IdMap.merge_elem SRecompose src_p src_q in
{ (nempty lab) with
nfv = xs;
na = acc;
nxml = single_prod src (nnode p xsp) (nnode q xsq)
}
......@@ -837,13 +758,13 @@ module Normal = struct
in
let src = IdMap.constant src xs in
{ (nempty lab) with
nfv = xs;
na = acc;
nrecord = RecLabel(label, single_prod src lft rgt) }
let nconstr lab t =
let aux l = NLineProd.from_list
(List.map (fun (t1,t2) -> empty_res, nc t1,nc t2) l) in
let aux l =
List.fold_left (fun accu (t1,t2) ->
NLineProd.add (empty_res, nc t1,nc t2) accu)
NLineProd.empty l in
let record = match lab with
| None ->
let (x,y) = Types.Record.empty_cases t in
......@@ -852,7 +773,6 @@ module Normal = struct
| Some l ->
RecLabel (l,aux (Types.Record.split_normal t l)) in
{ (nempty lab) with
na = t;
nbasic = single_basic empty_res (Types.cap t any_basic);
nprod = aux (Types.Product.normal t);
nxml = aux (Types.Product.normal ~kind:`XML t);
......@@ -860,9 +780,7 @@ module Normal = struct
}
let nany lab res =
{ nfv = IdMap.domain res;
na = Types.any;
nbasic = single_basic res any_basic;
{ nbasic = single_basic res any_basic;
nprod = single_prod res ncany ncany;
nxml = single_prod res ncany ncany;
nrecord = match lab with
......@@ -875,12 +793,6 @@ module Normal = struct
let rec nnormal lab ((acc,fv,d) as p) xs =
let xs = IdSet.cap xs fv in
(*
if not (IdSet.equal xs fv) then
(Format.fprintf Format.std_formatter
"ERR: p=%a xs=%a fv=%a@." Print.print p Print.print_xs xs Print.print_xs fv;
exit 1);
*)
if Types.is_empty acc then nempty lab
else if IdSet.is_empty xs then nconstr lab acc
else match d with
......@@ -901,10 +813,6 @@ module Normal = struct
directly shift it*)
let print_node_list ppf pl =
List.iter (fun p -> Format.fprintf ppf "%a;" Node.dump p) pl
let facto f t xs pl =
List.fold_left
(fun vs p -> IdSet.cup vs (f (descr p) t (IdSet.cap (fv p) xs)))
......@@ -919,50 +827,12 @@ module Normal = struct
(vs_var,vs_nil,(pl,t,xs))
let normal l t pl xs =
let a = nconstr l t in
(* let vs_var = facto Factorize.var t xs pl in
let xs = IdSet.diff xs vs_var in
let vs_var,a =
if f then vs_var,a
else
IdSet.empty,
List.fold_left (fun a x -> ncap a (ncapture l x)) a vs_var in
let vs_nil = facto Factorize.nil t xs pl in
let xs = IdSet.diff xs vs_nil in
let vs_nil,a =
if f then vs_nil,a
else
IdSet.empty,
List.fold_left
(fun a x -> ncap a (nconstant l x Sequence.nil_cst)) a vs_nil in
*)
List.fold_left (fun a p -> ncap a (nnormal l (descr p) xs)) a pl
List.fold_left
(fun a p -> ncap a (nnormal l (descr p) xs)) (nconstr l t) pl
let nnf lab t0 (pl,t,xs) =
let t = if Types.subtype t t0 then t else Types.cap t t0 in
normal lab t (NodeSet.get pl) xs
(*
let normal l t pl =
let nf = normal l t pl in
(match l with Some l ->
Format.fprintf Format.std_formatter
"normal(l=%a;t=%a;pl=%a)=%a@."
Label.print (LabelPool.value l)
Types.Print.print t
print_node_list pl
print nf
| None -> Format.fprintf Format.std_formatter
"normal(t=%a;pl=%a)=%a@."
Types.Print.print t
print_node_list pl
print nf);
nf
*)
end
......@@ -1337,8 +1207,8 @@ struct
let rec dispatch_prod ?(kind=`Normal) disp pl =
let extr = match kind with
| `Normal -> fun p -> Normal.NLineProd.get p.Normal.nprod
| `XML -> fun p -> Normal.NLineProd.get p.Normal.nxml in
| `Normal -> fun p -> Normal.NLineProd.elements p.Normal.nprod
| `XML -> fun p -> Normal.NLineProd.elements p.Normal.nxml in
let t = Types.Product.get ~kind disp.t in
dispatch_prod0 disp t (Array.map extr pl)
and dispatch_prod0 disp t pl =
......@@ -1389,7 +1259,7 @@ struct
let t = Types.Record.split t lab in
let pl = Array.map (fun p -> match p.Normal.nrecord with
| Normal.RecLabel (_,l) ->
Normal.NLineProd.get l
Normal.NLineProd.elements l
| _ -> assert false) pl in
Some (RecLabel (lab,dispatch_prod0 disp t pl))
......@@ -1912,9 +1782,6 @@ struct
let cur_id = State.ref "Patterns.cur_id" 0
(* TODO: save dispatchers ? *)
module NfMap = Map.Make(Normal)
module NfSet = Set.Make(Normal)
module DispMap = Map.Make(Custom.Pair(Types)(Custom.Array(Req)))
(* Try with a hash-table ! *)
......
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