Skip to content

GitLab

Commit 6dda32d0 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-12-20 16:47:07 by afrisch] Fix bug reported by JP Bodeveix 

Original author: afrisch
Date: 2004-12-20 16:47:07+00:00
parent 16b3a234
Hide whitespace changes
Inline Side-by-side
types/intervals.ml
View file @ 6dda32d0
......@@ -378,13 +378,14 @@ let mul l1 l2 =
) empty l1
(*
let dump s i =
let dmp s i =
let ppf = Format.std_formatter in
Format.fprintf ppf "%s = [ " s;
List.iter (fun x -> x ppf; Format.fprintf ppf " ") (print i);
Format.fprintf ppf "] "
(*
let diff i1 i2 =
let ppf = Format.std_formatter in
Format.fprintf ppf "Intervals.diff:";
......@@ -393,5 +394,15 @@ let diff i1 i2 =
dump "i1-i2" (diff i1 i2);
Format.fprintf ppf "@\n";
diff i1 i2
*)
(*
let cap i1 i2 =
let ppf = Format.std_formatter in
Format.fprintf ppf "Intervals.cap:";
dmp "i1" i1;
dmp "i2" i2;
dmp "i1*i2" (cap i1 i2);
Format.fprintf ppf "@.";
cap i1 i2
*)
types/normal.ml
View file @ 6dda32d0
......@@ -30,7 +30,9 @@ struct
let k = X1.diff s1 t1 in
let root = if not (X1.is_empty k) then (k, s2) :: root else root in
let j = X1.diff t1 s1 in
if not (X1.is_empty j) then add root j t2 rem else root
if not (X1.is_empty j)
then add root j t2 rem
else List.rev_append root rem
)
let normal x =
......
types/patterns.ml
View file @ 6dda32d0
......@@ -75,6 +75,11 @@ let print ppf d =
Format.fprintf ppf "%a@\n" print d;
dump_print ppf
let print_node ppf n =
Format.fprintf ppf "P%i" n.id;
to_print := n :: !to_print;
dump_print ppf
let counter = State.ref "Patterns.counter" 0
......@@ -130,7 +135,7 @@ module Node = struct
let hash n = n.id
let check n = ()
let dump ppf _ = Format.fprintf ppf "<Patterns.Node>"
let dump = print_node
module SMemo = Set.Make(Custom.Int)
......@@ -333,12 +338,25 @@ module Normal = struct
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)
type nnf = NodeSet.t * Types.t (* pl,t; t <= \accept{pl} *)
let check_nnf (pl,t) =
List.iter (fun p -> assert(Types.subtype t (Types.descr p.accept)))
(NodeSet.get pl)
let print_nnf ppf (pl,t) =
Format.fprintf ppf "@[(pl=%a;t=%a)@]" NodeSet.dump pl Types.Print.print t
let compare_nnf (l1,t1) (l2,t2) =
let c = NodeSet.compare l1 l2 in if c <> 0 then c
else Types.compare t1 t2
......@@ -363,8 +381,15 @@ module Normal = struct
module NLineProd =
SortedList.Make(
struct
include Custom.Dummy
(* include Custom.Dummy*)
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
print_nnf x
print_nnf y
type t = result * nnf * nnf
let compare (r1,x1,y1) (r2,x2,y2) =
let c = compare_result r1 r2 in if c <> 0 then c
......@@ -389,6 +414,21 @@ module Normal = struct
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;@[nrecord=@ @[%a@]@]}@]"
Types.Print.print nf.na
print_record nf.nrecord
let compare_nf t1 t2 =
if t1 == t2 then 0
else
......@@ -560,6 +600,16 @@ module Normal = struct
RecNolabel ((if x then Some empty_res else None),
(if y then Some empty_res else None))
| Some l ->
(*
let ppf = Format.std_formatter in
Format.fprintf ppf "Constr record t=%a l=%a@."
Types.Print.print t Label.print (LabelPool.value l);
let sp = Types.Record.split_normal t l in
List.iter (fun (t1,t2) ->
Format.fprintf ppf "t1=%a t2=%a@."
Types.Print.print t1
Types.Print.print t2) sp;
*)
RecLabel (l,aux (Types.Record.split_normal t l))
in
{ nempty lab with
......@@ -657,12 +707,33 @@ module Normal = struct
| RecLabel (lab,l) -> RecLabel (lab, nlinesprod l))
}
let print_node_list ppf pl =
List.iter (fun p -> Format.fprintf ppf "%a;" Node.dump p) pl
let normal l t pl =
remove_catchv
(List.fold_left
(fun a p -> ncap a (nnormal l (descr p)))
(nconstr l t)
pl)
(*
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
......@@ -868,10 +939,20 @@ struct
let dispatchers = ref DispMap.empty
let timer_disp = Stats.Timer.create "Patterns.dispatcher loop"
let rec print_iface ppf = function
| `Result i -> Format.fprintf ppf "Result(%i)" i
| `Switch (yes,no) -> Format.fprintf ppf "Switch(%a,%a)"
print_iface yes print_iface no
| `None -> Format.fprintf ppf "None"
let dispatcher t pl lab : dispatcher =
try DispMap.find (t,pl) !dispatchers
with Not_found ->
(* let ppf = Format.std_formatter in
Format.fprintf ppf "dispatcher %i:" !cur_id;
Array.iter (fun x -> Format.fprintf ppf "%a;" Normal.print x) pl;
Format.fprintf ppf "@."; *)
let nb = ref 0 in
let codes = ref [] in
let rec aux t arity i accu =
......@@ -880,7 +961,7 @@ struct
else
let p = pl.(i) in
let tp = p.Normal.na in
(* let tp = Types.normalize tp in *)
(* let tp = Types.normalize tp in *)
let a1 = Types.cap t tp in
if Types.is_empty a1 then
......@@ -904,15 +985,18 @@ struct
*)
in
(* Array.iteri (fun i p ->
(*
Array.iteri (fun i p ->
Format.fprintf Format.std_formatter
"Pattern %i/%i accepts %a@." i (Array.length pl)
Types.Print.print p.Normal.na) pl; *)
Types.Print.print p.Normal.na) pl;
*)
Stats.Timer.start timer_disp;
let iface =
if Types.is_empty t then `None else aux t 0 0 [] in
Stats.Timer.stop timer_disp ();
(* Format.fprintf Format.std_formatter "iface=%a@." print_iface iface;*)
let res = { id = !cur_id;
t = t;
label = lab;
......@@ -931,6 +1015,18 @@ struct
| `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes
| `Switch (_,no) -> aux (i + 1) no
in
(*
let ppf = Format.std_formatter in
Format.fprintf ppf "find_code iface=%a [ "
print_iface d.interface;
for i = 0 to Array.length a - 1 do
if (a.(i) != None) then
Format.fprintf ppf "+ "
else
Format.fprintf ppf "- "
done;
Format.fprintf ppf "]@.";
*)
aux 0 d.interface
let create_result pl =
......@@ -1031,6 +1127,7 @@ struct
let disp = dispatcher t ps lab in
let result (t,_,m) =
(* Format.fprintf Format.std_formatter "Result=%a@." Types.Print.print t;*)
let selected = Array.create (Array.length pl) [] in
let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
......@@ -1102,7 +1199,7 @@ struct
return disp pl aux_final
let rec dispatch_record disp : record option =
let dispatch_record disp : record option =
let t = disp.t in
if not (Types.Record.has_record t) then None
else
......@@ -1129,7 +1226,12 @@ struct
in
Some (RecNolabel (some,none))
| Some lab ->
(* Format.fprintf Format.std_formatter "lab=%a Split:@." Label.print (LabelPool.value lab);*)
let t = Types.Record.split t lab in
(* List.iter (fun (t1,t2) ->
Format.fprintf Format.std_formatter "t1=%a t2=%a@."
Types.Print.print t1
Types.Print.print t2) t; *)
let pl = Array.map (fun p -> match p.Normal.nrecord with
| Normal.RecLabel (_,l) ->
Normal.NLineProd.get l
......@@ -1246,18 +1348,14 @@ struct
in
let rec print_record_opt ppf = function
| None -> ()
| Some r ->
Format.fprintf ppf " | Record -> @\n";
Format.fprintf ppf " @[%a@]@\n" print_record r
and print_record ppf = function
| RecNolabel (r1,r2) ->
Format.fprintf ppf "SomeField:%a;NoField:%a"
print_ret_opt r1 print_ret_opt r2
| RecLabel (l, d) ->
| Some (RecLabel (l,d)) ->
let l = LabelPool.value l in
Format.fprintf ppf "check label %a:@\n" Label.print l;
Format.fprintf ppf "Present => @[%a@]@\n" (print_prod "record") d
in
print_prod ("record:"^(Label.to_string l)) ppf d
| Some (RecNolabel (r1,r2)) ->
Format.fprintf ppf " | Record -> @\n";
Format.fprintf ppf " SomeField:%a;NoField:%a@\n"
print_ret_opt r1 print_ret_opt r2
in
List.iter print_basic actions.basic;
print_prod "" ppf actions.prod;
......@@ -1269,7 +1367,7 @@ struct
| AIgnore r -> Format.fprintf ppf "v -> %a@\n" print_ret r
let print_dispatcher ppf d =
(* Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
d.id Types.Print.print (Types.normalize d.t);
let print_code code (t, arity, m) =
Format.fprintf ppf " Returns $%i(arity=%i) for [%a]"
......@@ -1287,7 +1385,7 @@ struct
Format.fprintf ppf "@\n";
in
Array.iteri print_code d.codes; *)
Array.iteri print_code d.codes;
Format.fprintf ppf "let disp_%i = function@\n" d.id;
print_actions ppf (actions d);
Format.fprintf ppf "====================================@\n"
......
types/types.ml
View file @ 6dda32d0
......@@ -891,7 +891,7 @@ and check_arrow (left,right) s =
big_conj single_right right s
and check_record (labels,(oleft,left),rights) s =
let rec aux rights s = match rights with
let rec aux left rights s = match rights with
| [] -> set s
| (oright,right)::rights ->
let next =
......@@ -899,21 +899,17 @@ and check_record (labels,(oleft,left),rights) s =
exists (Array.length left)
(fun i -> trivially_disjoint left.(i) right.(i))
in
if next then aux rights s
if next then aux left rights s
else
for i = 0 to Array.length left - 1 do
let back = left.(i) in
let di = diff back right.(i) in
guard (slot di) (fun s ->
left.(i) <- di;
aux rights s;
left.(i) <- back;
) s
(* TODO: are side effects correct ? *)
let left' = Array.copy left in
let di = diff left.(i) right.(i) in
left'.(i) <- di;
guard (slot di) (aux left' rights) s;
done
in
let rec start i s =
if (i < 0) then aux rights s
if (i < 0) then aux left rights s
else
guard (slot left.(i)) (start (i - 1)) s
in
......@@ -1295,7 +1291,7 @@ struct
(LabelMap.get r);
Format.fprintf ppf "}"
| String (i,j,s,c) ->
Format.fprintf ppf "\"%a\" @ %a"
Format.fprintf ppf "\"%a\" %a"
U.print (U.mk (U.get_substr s i j))
print_const c
......@@ -1323,6 +1319,7 @@ struct
| Record of (bool * t) label_map * bool * bool
| Arrows of (t * t) list * (t * t) list
| Neg of t
| Abs of t
let compare x y = x.id - y.id
end
module Decompile = Pretty.Decompile(DescrHash)(S)
......@@ -1385,6 +1382,8 @@ struct
DescrHash.add memo d s;
s
with Not_found ->
if d.absent then alloc [Abs (prepare ({d with hash=0; absent=false}))]
else
if worth_complement d then
alloc [Neg (prepare (neg d))]
else
......@@ -1438,6 +1437,7 @@ struct
let p = List.map aux p and n = List.map aux n in
add (Arrows (p,n)))
(BoolPair.get not_seq.arrow);
if not_seq.absent then add (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT"));
slot.def <- List.rev slot.def;
slot
......@@ -1464,6 +1464,7 @@ struct
| _ -> ()
and assign_name_rec = function
| Neg t -> assign_name t
| Abs t -> assign_name t
| Name _ | Char _ | Atomic _ -> ()
| Regexp r -> assign_name_regexp r
| Pair (t1,t2) -> assign_name t1; assign_name t2
......@@ -1497,7 +1498,9 @@ struct
then Format.fprintf ppf "@[(%a)@]" aux def
else aux ppf def
and do_print ppf = function
(* | Neg { def = [] } -> Format.fprintf ppf "Any" *)
| Neg t -> Format.fprintf ppf "Any \\ (@[%a@])" (do_print_slot 0) t
| Abs t -> Format.fprintf ppf "?(@[%a@])" (do_print_slot 0) t
| Name n -> Format.fprintf ppf "%a" U.print n
| Char c -> Chars.V.print ppf c
| Regexp r -> Format.fprintf ppf "@[[ %a ]@]" (do_print_regexp 0) r
......
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