Skip to content

GitLab

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

[r2002-10-23 09:22:04 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-10-23 09:22:04+00:00
parent d799eb13
Hide whitespace changes
Inline Side-by-side
types/patterns.ml
View file @ a054f94b
......@@ -127,12 +127,25 @@ struct
]
type result = (capture, source) sm
type 'a line = (result * 'a, Types.descr) sm
type nf = {
v : fv;
a : Types.descr;
basic : (result, Types.descr) sm;
prod : (result * Types.descr * node sl * node sl) sl;
record: (result * Types.descr * (Types.label, node sl) sm) sl;
basic : unit line;
prod : (node sl * node sl) line;
record: ((Types.label, node sl) sm) line
}
type 'a nline = (result * 'a) list
type record =
[ `Success
| `Fail
| `Dispatch of (nf * record) list
| `Label of Types.label * (nf * record) list * record ]
type normal = {
nbasic : Types.descr nline;
nprod : (nf * nf) nline;
nrecord: record nline
}
let empty = { v = []; a = Types.empty; basic = []; prod = []; record = [] }
......@@ -140,70 +153,55 @@ struct
let restrict t nf =
let map_filter f l =
let g accu x = match f x with Some y -> y::accu | None -> accu in
SortedList.from_list (List.fold_left g [] l) in
let aux_basic (res,bt) =
let bt = Types.cap t bt in
if Types.is_empty bt then None else Some (res,bt) in
let aux_prod (res,bt,p,q) =
let bt = Types.cap t bt in
if Types.is_empty bt then None else Some (res,bt,p,q) in
let aux_record (res,bt,r) =
let bt = Types.cap t bt in
if Types.is_empty bt then None else Some (res,bt,r) in
let rec filter = function
| (key,acc) :: rem ->
let acc = Types.cap t acc in
if Types.is_empty acc then filter rem else (key,acc) :: (filter rem)
| [] -> []
in
{ v = nf.v;
a = Types.cap t nf.a;
basic = map_filter aux_basic nf.basic;
prod = map_filter aux_prod nf.prod;
record = map_filter aux_record nf.record;
basic = filter nf.basic;
prod = filter nf.prod;
record = filter nf.record;
}
let fus = SortedMap.union_disj
let slcup = SortedList.cup
let cap nf1 nf2 =
let aux f x1 x2 =
SortedList.from_list
(List.fold_left (fun accu a -> List.fold_left (f a) accu x2) [] x1) in
let aux_basic (res1,t1) accu (res2,t2) =
let t = Types.cap t1 t2 in
if Types.is_empty t then accu
else (fus res1 res2, t)::accu in
let aux_prod (res1,t1,p1,q1) accu (res2,t2,p2,q2) =
let t = Types.cap t1 t2 in
if Types.is_empty t then accu
else (fus res1 res2, t, slcup p1 p2, slcup q1 q2)::accu in
let aux_record (res1,t1,r1) accu (res2,t2,r2) =
let t = Types.cap t1 t2 in
if Types.is_empty t then accu
else (fus res1 res2, t, SortedMap.union slcup r1 r2)
::accu in
let merge f lines1 lines2 =
let m =
List.fold_left
(fun accu ((res1,x1),acc1) ->
List.fold_left
(fun accu ((res2,x2),acc2) ->
let acc = Types.cap acc1 acc2 in
if Types.is_empty acc then accu
else ((fus res1 res2, f x1 x2),acc) :: accu
) accu lines2
) [] lines1 in
SortedMap.from_list Types.cup m
in
let merge_basic () () = ()
and merge_prod (p1,q1) (p2,q2) = slcup p1 p1, slcup q1 q2
and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
{ v = SortedList.cup nf1.v nf2.v;
a = Types.cap nf1.a nf2.a;
basic = SortedMap.from_sorted_list Types.cup
(aux aux_basic nf1.basic nf2.basic);
prod = aux aux_prod nf1.prod nf2.prod;
record = aux aux_record nf1.record nf2.record;
basic = merge merge_basic nf1.basic nf2.basic;
prod = merge merge_prod nf1.prod nf2.prod;
record = merge merge_record nf1.record nf2.record;
}
let cup acc1 nf1 nf2 =
let nf2 = restrict (Types.neg acc1) nf2 in
{ v = SortedList.cup nf1.v nf2.v;
{ v = nf1.v; (* = nf2.v *)
a = Types.cup nf1.a nf2.a;
basic = SortedMap.union Types.cup nf1.basic nf2.basic;
prod = SortedList.cup nf1.prod nf2.prod;
record = SortedList.cup nf1.record nf2.record;
prod = SortedMap.union Types.cup nf1.prod nf2.prod;
record = SortedMap.union Types.cup nf1.record nf2.record;
}
let times acc p q =
......@@ -213,47 +211,47 @@ struct
{ empty with
v = SortedList.cup p.fv q.fv;
a = acc;
prod = [ src, acc, [p], [q] ] }
prod = [ (src, ([p], [q])), acc ] }
let record acc l p =
let src = List.map (fun v -> (v, `Field l)) p.fv in
{ empty with
v = p.fv;
a = acc;
record = [ src, acc, [l,[p]] ] }
record = [ (src, [l,[p]]), acc ] }
let any =
{ v = [];
a = Types.any;
basic = [ [], any_basic ];
prod = [ [], Types.Product.any,[],[] ];
record = [ [], Types.Record.any,[] ];
basic = [ ([],()), any_basic ];
prod = [ ([],([],[])), Types.Product.any ];
record = [ ([],[]), Types.Record.any ];
}
let capture x =
let l = [x,`Catch] in
{ v = [x];
a = Types.any;
basic = [ l, any_basic ];
prod = [ l, Types.Product.any,[],[] ];
record = [ l, Types.Record.any,[] ];
basic = [ (l,()), any_basic ];
prod = [ (l,([],[])), Types.Product.any ];
record = [ (l,[]), Types.Record.any ];
}
let constant x c =
let l = [x,`Const c] in
{ v = [x];
a = Types.any;
basic = [ l, any_basic ];
prod = [ l, Types.Product.any,[],[] ];
record = [ l, Types.Record.any,[] ];
basic = [ (l,()), any_basic ];
prod = [ (l,([],[])), Types.Product.any ];
record = [ (l,[]), Types.Record.any ];
}
let constr t =
{ v = [];
a = t;
basic = [ [], Types.cap t any_basic ];
prod = [ [], Types.cap t Types.Product.any,[],[] ];
record = [ [], Types.cap t Types.Record.any,[] ];
basic = [ ([],()), Types.cap t any_basic ];
prod = [ ([],([],[])), Types.cap t Types.Product.any ];
record = [ ([],[]), Types.cap t Types.Record.any ];
}
(* Put a pattern in normal form *)
......@@ -280,7 +278,7 @@ struct
masks : (mask * int) list;
basic : (Types.descr * (result option list)) list;
prod : prod;
record: record;
record: record option;
}
and prod = disp * (mask * disp * (mask * prod_result) list) list
and prod_result = (result * (int * int)) option list
......@@ -293,7 +291,51 @@ struct
and mask = bool list
and disp = Types.descr * nf SortedList.t
end
let normal nf =
let basic =
List.map (fun ((res,()),acc) -> (res,acc))
and prod =
let line accu (((res,(pl,ql)),acc)) =
let p = bigcap pl and q = bigcap ql in
let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
List.fold_left aux accu (Types.Product.normal acc) in
List.fold_left line []
and record =
let rec aux nr fields =
match (nr,fields) with
| (`Success, []) -> `Success
| (`Fail,_) -> `Fail
| (`Success, (l2,pl)::fields) ->
`Label (l2, [bigcap pl, aux nr fields], `Fail)
| (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
`Label (l2, [bigcap pl, aux nr fields], `Fail)
| (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
let p = bigcap pl in
let pr =
List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in
`Label (l1, pr, `Fail)
| (`Label (l1, pr, ab),_) ->
let pr =
List.map (fun (t,x) -> (constr t, aux x fields)) pr in
`Label (l1, pr, aux ab fields)
in
let line accu ((res,fields),acc) =
let nr = Types.Record.normal acc in
let x = aux nr fields in
match x with
| `Fail -> accu
| x -> (res,x) :: accu in
List.fold_left line []
in
{ nbasic = basic nf.basic;
nprod = prod nf.prod;
nrecord = record nf.record;
}
let collect f pp =
let aux accu (res,x) = (f x) :: accu in
SortedList.from_list (List.fold_left (List.fold_left aux) [] pp)
......@@ -326,7 +368,7 @@ struct
let accu = aux pl accu (Types.diff t ty) rem in
accu
in
let pl = List.map (fun p -> p.basic) pl in
let pl = List.map (fun p -> p.nbasic) pl in
let tests = collect (fun x -> x) pl in
let t = Types.cap any_basic t in
aux pl [] t tests
......@@ -341,15 +383,8 @@ struct
let aux (res,(i,q)) = (res,(i,List.assoc q success)) in
List.map (extract_unique aux)
let prepare_prod p =
let line accu (res,t,pl,ql) =
let p = bigcap pl and q = bigcap ql in
let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
List.fold_left aux accu (Types.Product.normal t) in
List.fold_left line [] p.prod
let rec dispatch_prod t pl =
let pl = List.map prepare_prod pl in
let pl = List.map (fun p -> p.nprod) pl in
let tests = collect (fun (p,_) -> p) pl in
let t = Types.Product.get t in
let disp = aux_prod1 t pl [] [] [] 0 tests in
......@@ -392,11 +427,6 @@ struct
(* Record types *)
type record =
[ `Success
| `Fail
| `Dispatch of (nf * record) list
| `Label of Types.label * (nf * record) list * record ]
let map_record f =
let rec aux = function
......@@ -453,41 +483,13 @@ struct
| _ -> assert false in
List.map aux
let rec cap_record nr fields =
match (nr,fields) with
| (`Success, []) -> `Success
| (`Fail,_) -> `Fail
| (`Success, (l2,pl)::fields) ->
`Label (l2, [bigcap pl, cap_record nr fields], `Fail)
| (`Label (l1, _, _), (l2,pl)::fields)
when l2 < l1 ->
`Label (l2, [bigcap pl, cap_record nr fields], `Fail)
| (`Label (l1, pr, _), (l2,pl)::fields)
when l1 = l2 ->
let p = bigcap pl in
let pr =
List.map (fun (t,x) -> (restrict t p, cap_record x fields)) pr in
`Label (l1, pr, `Fail)
| (`Label (l1, pr, ab),_) ->
let pr =
List.map (fun (t,x) -> (constr t, cap_record x fields)) pr in
`Label (l1, pr, cap_record ab fields)
let prepare_record =
map_record
(function (res,t,fields) ->
let nr = Types.Record.normal t in
let x = cap_record nr fields in
(res, [], x)
)
(* combiner les restrict field, ... *)
let rec dispatch_record t pl =
let pl = prepare_record (List.map (fun p -> p.record) pl) in
let pl = List.map
(fun p -> List.map (fun (res,r) -> (res,[],r)) p.nrecord
) pl in
let t = Types.Record.get t in
aux_record1 t pl
if Types.Record.is_empty t then None else Some (aux_record1 t pl)
and aux_record1 t pl =
match collect_first_label pl with
......@@ -523,11 +525,12 @@ struct
let t = Types.Record.restrict_field t l (Types.neg p.a) in
aux_record2 t pl l accu (false::mask) success (i+1) rem in
accu
let mask l = List.map (function None -> false | Some _ -> true) l
let rec dispatch (t : Types.descr) (pl : nf list) =
let pl = List.map (restrict t) pl in
let fv = List.map (fun p -> p.v) pl in
let pl = List.map (fun p -> normal (restrict t p)) pl in
let basic = dispatch_basic t pl
and prod = dispatch_prod t pl
and record = dispatch_record t pl in
......@@ -540,7 +543,7 @@ struct
num 0 (SortedList.from_list !accu) in
{
Dispatch.fv = List.map (fun p -> p.v) pl;
Dispatch.fv = fv;
Dispatch.masks = masks;
Dispatch.basic = basic;
Dispatch.prod = prod;
......@@ -651,9 +654,11 @@ struct
(no t2 pl2);
List.iter (case_prod2 ppf pl2) cases2
and show_record ppf r =
Format.fprintf ppf " | Record r -> @\n";
Format.fprintf ppf " @[%a@]@\n" show_record_aux r
and show_record ppf = function
| None -> ()
| Some r ->
Format.fprintf ppf " | Record r -> @\n";
Format.fprintf ppf " @[%a@]@\n" show_record_aux r
and show_record_aux ppf = function
| `Result r ->
......@@ -739,3 +744,5 @@ showt " [ (1 3?)* ]" [ " [(1 (x::3)?)*] " ];;
#install_printer Types.Print.print_descr;;
let (t,[p1;p2]) = Patterns.NF.get 5;;
*)
types/sortedMap.ml
View file @ a054f94b
......@@ -61,3 +61,6 @@ let rec from_sorted_list f = function
from_sorted_list f ((x1, (f y1 y2))::q)
| (x,y)::q -> (x,y)::(from_sorted_list f q)
| l -> l
let from_list f l =
from_sorted_list f (List.sort (fun (a1,b1) (a2,b2) -> compare a1 a2) l)
types/sortedMap.mli
View file @ a054f94b
......@@ -16,3 +16,4 @@ val iter2:
val from_sorted_list : ('b -> 'b -> 'b) -> ('a * 'b) SortedList.t -> ('a,'b) t
val from_list: ('b -> 'b -> 'b) -> ('a * 'b) list -> ('a,'b) t
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