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

[r2002-11-26 14:13:32 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-26 14:13:33+00:00
parent fd4276ce
...@@ -112,25 +112,23 @@ let debug ppf = function ...@@ -112,25 +112,23 @@ let debug ppf = function
Patterns.Compile.debug_compile ppf t pl Patterns.Compile.debug_compile ppf t pl
| `Normal_record t -> | `Normal_record t ->
Format.fprintf ppf "[DEBUG:normal_record]@\n"; Format.fprintf ppf "[DEBUG:normal_record]@\n";
() let t = Types.Record.get (Types.descr (Typer.typ !glb_env t)) in
(*
let t = Types.descr (Typer.typ !glb_env t) in
let count = ref 0 and seen = ref [] in
match Types.Record.first_label t with match Types.Record.first_label t with
| `Empty -> Format.fprintf ppf "Empty" | `Fail -> Format.fprintf ppf "Empty"
| `Any -> Format.fprintf ppf "Any" | `Success -> Format.fprintf ppf "{ }"
| `NoField -> Format.fprintf ppf "{| |}"
| `SomeField -> Format.fprintf ppf "{ } \ {| |}"
| `Label l -> | `Label l ->
let (pr,ab) = Types.Record.normal' t l in let (pr,ab) = Types.Record.normal' t l in
Format.fprintf ppf "Label (%s,@[" (Types.LabelPool.value l); Format.fprintf ppf "Label (%s,@[" (Types.LabelPool.value l);
List.iter (fun (d,n) -> List.iter (fun (d,n) ->
Format.fprintf ppf "%a => @[%a@];@\n" Format.fprintf ppf "%a => @[%a@];@\n"
Types.Print.print_descr d Types.Print.print_descr d
Types.Print.print_descr n Types.Print.print_descr (Types.Record.descr n)
) pr; ) pr;
Format.fprintf ppf "@] Absent: @[%a@])@\n" Format.fprintf ppf "@] Absent: @[%a@])@\n"
Types.Print.print_descr Types.Print.print_descr
(match ab with Some x -> x | None -> Types.empty) (Types.Record.descr ab)
*)
(* (*
| `Normal_record t -> | `Normal_record t ->
Format.fprintf ppf "[DEBUG:normal_record]@\n"; Format.fprintf ppf "[DEBUG:normal_record]@\n";
......
...@@ -954,12 +954,39 @@ struct ...@@ -954,12 +954,39 @@ struct
let get d = d.record let get d = d.record
module T = struct
type t = descr
let any = any
let cap = cap
let cup = cup
let diff = diff
let empty = is_empty
end
module R = struct
(*Note: Boolean.cap,cup,diff would be ok,
but we add here the simplification rules:
{ } & r --> r ; { } | r -> { }
r \ { } --> Empty *)
type t = atom Boolean.t
let any = Boolean.full
let cap = Boolean.cap
let cup = Boolean.cup
let diff = Boolean.diff
let empty x = is_empty { empty with record = x }
end
module TR = Normal.Make(T)(R)
let atom = function
| (true,[]) -> Boolean.full
| (o,l) -> Boolean.atom (o,l)
let restrict_label_absent t l = let restrict_label_absent t l =
Boolean.compute_bool Boolean.compute_bool
(fun (o,r) as x -> (fun (o,r) as x ->
try try
let (lo,_) = List.assoc l r in let (lo,_) = List.assoc l r in
if lo then Boolean.atom (o,SortedMap.diff r [l]) if lo then atom (o,SortedMap.diff r [l])
else Boolean.empty else Boolean.empty
with Not_found -> Boolean.atom x with Not_found -> Boolean.atom x
) )
...@@ -973,30 +1000,13 @@ struct ...@@ -973,30 +1000,13 @@ struct
try try
let (lo,lt) = List.assoc l r in let (lo,lt) = List.assoc l r in
if (not lo) && (is_empty (cap d (descr lt))) then Boolean.empty if (not lo) && (is_empty (cap d (descr lt))) then Boolean.empty
else Boolean.atom (o, SortedMap.diff r [l]) else atom (o, SortedMap.diff r [l])
with Not_found -> with Not_found ->
if o then Boolean.atom x else Boolean.empty if o then Boolean.atom x else Boolean.empty
) )
t t
module T = struct
type t = descr
let any = any
let cap = cap
let cup = cup
let diff = diff
let empty = is_empty
end
module R = struct
type t = atom Boolean.t
let any = Boolean.full
let cap = Boolean.cap
let cup = Boolean.cup
let diff = Boolean.diff
let empty x = is_empty { empty with record = x }
end
module TR = Normal.Make(T)(R)
let label_present (t:t) l : (descr * t) list = let label_present (t:t) l : (descr * t) list =
let x = let x =
...@@ -1004,7 +1014,7 @@ struct ...@@ -1004,7 +1014,7 @@ struct
(fun (o,r) as x -> (fun (o,r) as x ->
try try
let (_,lt) = List.assoc l r in let (_,lt) = List.assoc l r in
Boolean.atom (descr lt, Boolean.atom (o, SortedMap.diff r [l])) Boolean.atom (descr lt, atom (o, SortedMap.diff r [l]))
with Not_found -> with Not_found ->
if o then Boolean.atom (any, Boolean.atom x) else Boolean.empty if o then Boolean.atom (any, Boolean.atom x) else Boolean.empty
) )
...@@ -1012,17 +1022,6 @@ struct ...@@ -1012,17 +1022,6 @@ struct
in in
TR.boolean x TR.boolean x
let is_label_present t l =
Boolean.compute
~empty:false ~full:true
~cup:(||) ~cap:(&&)
~diff:(fun x y -> x && not y)
~atom:(fun (o,r) ->
try let (lo,_) = List.assoc l r in not lo
with Not_found -> false
)
t
let restrict_label_present t l = let restrict_label_present t l =
t t
(* (*
...@@ -1036,7 +1035,9 @@ struct ...@@ -1036,7 +1035,9 @@ struct
let project t l = let project t l =
let t = get t in let t = get t in
if is_label_present t l then project_field t l else raise Not_found let r = label_present t l in
if r = [] then raise Not_found else
List.fold_left (fun accu (d,_) -> cup accu d) empty r
type normal = type normal =
[ `Success [ `Success
...@@ -1073,6 +1074,11 @@ struct ...@@ -1073,6 +1074,11 @@ struct
| _ -> `Success | _ -> `Success
let normal' t l =
let present = label_present t l
and absent = restrict_label_absent t l in
List.map (fun (d,t) -> d,t) present, absent
let rec normal_aux t = let rec normal_aux t =
match first_label t with match first_label t with
| `Label l -> | `Label l ->
......
...@@ -126,10 +126,10 @@ module Record : sig ...@@ -126,10 +126,10 @@ module Record : sig
val normal: descr -> normal val normal: descr -> normal
(* val normal': t -> label -> (descr * t) list * t
val normal': descr -> label -> (descr * descr) list * descr option val first_label: t -> [ `Success|`Fail|`NoField|`SomeField|`Label of label ]
val first_label: descr -> [ `Empty | `Any | `Label of label ]
(*
val project : descr -> label -> descr val project : descr -> label -> descr
(* Raise Not_found if label is not necessarily present *) (* Raise Not_found if label is not necessarily present *)
*) *)
......
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