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
Patterns.Compile.debug_compile ppf t pl
| `Normal_record t ->
Format.fprintf ppf "[DEBUG:normal_record]@\n";
()
(*
let t = Types.descr (Typer.typ !glb_env t) in
let count = ref 0 and seen = ref [] in
let t = Types.Record.get (Types.descr (Typer.typ !glb_env t)) in
match Types.Record.first_label t with
| `Empty -> Format.fprintf ppf "Empty"
| `Any -> Format.fprintf ppf "Any"
| `Fail -> Format.fprintf ppf "Empty"
| `Success -> Format.fprintf ppf "{ }"
| `NoField -> Format.fprintf ppf "{| |}"
| `SomeField -> Format.fprintf ppf "{ } \ {| |}"
| `Label l ->
let (pr,ab) = Types.Record.normal' t l in
Format.fprintf ppf "Label (%s,@[" (Types.LabelPool.value l);
List.iter (fun (d,n) ->
Format.fprintf ppf "%a => @[%a@];@\n"
Types.Print.print_descr d
Types.Print.print_descr n
Types.Print.print_descr (Types.Record.descr n)
) pr;
Format.fprintf ppf "@] Absent: @[%a@])@\n"
Types.Print.print_descr
(match ab with Some x -> x | None -> Types.empty)
*)
(Types.Record.descr ab)
(*
| `Normal_record t ->
Format.fprintf ppf "[DEBUG:normal_record]@\n";
......
......@@ -954,12 +954,39 @@ struct
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 =
Boolean.compute_bool
(fun (o,r) as x ->
try
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
with Not_found -> Boolean.atom x
)
......@@ -973,30 +1000,13 @@ struct
try
let (lo,lt) = List.assoc l r in
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 ->
if o then Boolean.atom x else Boolean.empty
)
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 x =
......@@ -1004,7 +1014,7 @@ struct
(fun (o,r) as x ->
try
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 ->
if o then Boolean.atom (any, Boolean.atom x) else Boolean.empty
)
......@@ -1012,17 +1022,6 @@ struct
in
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 =
t
(*
......@@ -1036,7 +1035,9 @@ struct
let project t l =
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 =
[ `Success
......@@ -1073,6 +1074,11 @@ struct
| _ -> `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 =
match first_label t with
| `Label l ->
......
......@@ -126,10 +126,10 @@ module Record : sig
val normal: descr -> normal
(*
val normal': descr -> label -> (descr * descr) list * descr option
val first_label: descr -> [ `Empty | `Any | `Label of label ]
val normal': t -> label -> (descr * t) list * t
val first_label: t -> [ `Success|`Fail|`NoField|`SomeField|`Label of label ]
(*
val project : descr -> label -> descr
(* 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