Commit a0a8da35 authored by Pietro Abate's avatar Pietro Abate

[r2002-11-02 19:24:08 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-02 19:24:09+00:00
parent 3aa4b435
......@@ -85,7 +85,52 @@ let debug = function
(List.map (fun p -> Patterns.Compile.normal
(Patterns.descr p)) pl) in
Patterns.Compile.show ppf (Types.descr t) pl
| _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
| `Normal_record t ->
Format.fprintf ppf "[DEBUG:normal_record]@\n";
let t = Types.descr (Typer.typ t) in
let count = ref 0 and seen = ref [] in
match Types.Record.first_label t with
| `Empty -> Format.fprintf ppf "Empty"
| `Any -> Format.fprintf ppf "Any"
| `Label l ->
let (pr,ab) = Types.Record.normal' t l in
Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
List.iter (fun (d,n) ->
Format.fprintf ppf "%a => @[%a@];@\n"
Types.Print.print_descr d
Types.Print.print_descr n
) pr;
Format.fprintf ppf "@] Absent: @[%a@])@\n"
Types.Print.print_descr
(match ab with Some x -> x | None -> Types.empty)
(*
| `Normal_record t ->
Format.fprintf ppf "[DEBUG:normal_record]@\n";
let t = Types.descr (Typer.typ t) in
let r = Types.Record.normal t in
let count = ref 0 and seen = ref [] in
let rec aux ppf x =
try
let no = List.assq x !seen in
Format.fprintf ppf "[[%i]]" no
with Not_found ->
incr count;
seen := (x, !count) :: !seen;
Format.fprintf ppf "[[%i]]:" !count;
match x with
| `Success -> Format.fprintf ppf "Success"
| `Fail -> Format.fprintf ppf "Fail"
| `Label (l,pr,ab) ->
Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
List.iter (fun (d,n) ->
Format.fprintf ppf "%a => @[%a@];@\n"
Types.Print.print_descr d
aux n
) pr;
Format.fprintf ppf "@] Absent: @[%a@])" aux ab
in
Format.fprintf ppf "%a@\n" aux r
*)
let typing_env = ref Typer.Env.empty
let eval_env = ref Eval.Env.empty
......
......@@ -15,7 +15,9 @@ and pmodule_item' =
and debug_directive =
[ `Filter of ppat * ppat
| `Accept of ppat
| `Compile of ppat * ppat list ]
| `Compile of ppat * ppat list
| `Normal_record of ppat
]
and pexpr = pexpr' located
......
......@@ -58,8 +58,9 @@ EXTEND
debug_directive: [
[ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
| LIDENT "accept"; p = pat -> `Accept p;
| LIDENT "accept"; p = pat -> `Accept p
| LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
| LIDENT "normal_record"; t = pat -> `Normal_record t
]
];
......
......@@ -93,23 +93,24 @@ and run_disp_prod2 v1 r1 v v2 x =
and run_disp_record f v bindings fields = function
| None -> assert false
| Some record -> run_disp_record' f v bindings fields record
| Some record -> run_disp_record' f v bindings None fields record
and run_disp_record' f v bindings fields = function
and run_disp_record' f v bindings abs fields = function
| `Result r -> make_result_record f v bindings r
| `Absent -> run_disp_record f v bindings fields abs
| `Label (l, present, absent) ->
let rec aux = function
| (l1,_) :: rem when l1 < l -> aux rem
| (l1,vl) :: rem when l1 = l ->
run_disp_field f v bindings rem l vl present
run_disp_field f v bindings abs rem l vl present
| _ -> run_disp_record f v bindings fields absent
in
aux fields
and run_disp_field f v bindings fields l vl = function
and run_disp_field f v bindings abs fields l vl = function
| `None -> assert false
| `Ignore r -> run_disp_record' f v bindings fields r
| `Ignore r -> run_disp_record' f v bindings abs fields r
| `TailCall d -> run_dispatcher d vl
| `Dispatch (dl,bl) ->
let (codel,rl) = run_dispatcher dl vl in
run_disp_record' f v ((l,rl)::bindings) fields bl.(codel)
run_disp_record' f v ((l,rl)::bindings) abs fields bl.(codel)
type T =
{ a =? `A; b =? `A; c =? `A;
d =? `A; e =? `A; f =? `A;
g =? `A; h =? `A; i =? `A;
j =? `A; k =? `A; l =? `A;
m =? `A; n =? `A; o =? `A;
p =? `A; q =? `A; r =? `A };;
debug compile Any T;;
debug compile T
({ a = x } | ( x:= `B)) &
({ b = y } | ( y:= `B)) &
({ c = z } | ( z:= `B))
;;
type T = [ `A? `B? `C? `D? `E? `F? `G? `H? `I? `J?
`K? `L? `M? `N? `O? `P? `Q? `R? ];;
debug compile Any T;;
(*
debug compile T
P1 where
P1 = (`A & (a := 1), P2) | (a := 2) & P2 and
P2 = (`B & (b := 1), P3) | (b := 2) & P3 and
P3 = (`C & (c := 1), P4) | (c := 2) & P4 and
P4 = (`D & (d := 1), P5) | (d := 2) & P5 and
P5 = `nil;;
match [ `A `B `C ] with (P1 where
P1 = (`A & (a := 1), P2) | (a := 2) & P2 and
P2 = (`B & (b := 1), P3) | (b := 2) & P3 and
P3 = (`C & (c := 1), P4) | (c := 2) & P4 and
P4 = (`D & (d := 1), P5) | (d := 2) & P5 and
P5 = `nil) -> (a,b,c,d);;
*)
......@@ -317,9 +317,14 @@ struct
List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in
`Label (l1, pr, `Fail)
| (`Label (l1, pr, ab),_) ->
let aux_ab = aux ab fields in
let pr =
List.map (fun (t,x) -> (constr t, aux x fields)) pr in
`Label (l1, pr, aux ab fields)
List.map (fun (t,x) -> (constr t,
(* Types.Record.normal enforce physical equility
in case of a ? field *)
if x==ab then aux_ab else
aux x fields)) pr in
`Label (l1, pr, aux_ab)
in
let line accu ((res,fields),acc) =
......@@ -355,7 +360,8 @@ struct
}
and record =
[ `Label of Types.label * record dispatch * record option
| `Result of result ]
| `Result of result
| `Absent ]
and 'a dispatch =
[ `Dispatch of dispatcher * 'a array
......@@ -439,6 +445,7 @@ struct
let combine_record l present absent =
match (present,absent) with
| (`Ignore r1, Some r2) when r1 = r2 -> r1
| (`Ignore `Absent, Some r) -> r
| (`Ignore r, None) -> r
| _ -> `Label (l, present, absent)
......@@ -587,7 +594,7 @@ struct
let conv_source_record catch (v,s) = match s with
| (`Catch | `Const _) as x -> x
| `Field l -> `Field (l, assoc v (List.assoc l catch))
| `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
| _ -> assert false
......@@ -724,14 +731,62 @@ struct
| (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
| x -> x)
let memo_dispatch_record = ref []
let memo_dr_count = ref 0
let rec print_normal_record ppf = function
| `Success -> Format.fprintf ppf "Success"
| `Fail -> Format.fprintf ppf "Fail"
| `Label (l,pr,ab) ->
Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.label_name l)
print_normal_record_pr pr
print_normal_record ab
| _ -> assert false
and print_normal_record_pr ppf =
List.iter (fun (nf,r) ->
Format.fprintf ppf "[_,%a]"
print_normal_record r)
let dump_dr ppf pl =
Array.iteri
(fun i x ->
Format.fprintf ppf "[%i:]" i;
List.iter
(fun (res,catch,nr) ->
Format.fprintf ppf "Result:";
List.iter (fun (x,s) -> Format.fprintf ppf "%s," x) res;
Format.fprintf ppf "Catch:";
List.iter (fun (l,r) ->
Format.fprintf ppf "%s[" (Types.label_name l);
List.iter (fun (x,i) ->
Format.fprintf ppf "%s->%i" x i) r;
Format.fprintf ppf "]"
) catch;
Format.fprintf ppf "NR:%a" print_normal_record nr
) x;
Format.fprintf ppf "@\n"
) pl
let rec dispatch_record disp : record option =
let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
let pl0 = Array.map prep disp.pl in
let t = Types.Record.get disp.t in
dispatch_record_opt disp t pl0
let r = dispatch_record_opt disp t pl0 in
memo_dispatch_record := [];
r
and dispatch_record_opt disp t pl =
if Types.Record.is_empty t then None
else Some (dispatch_record_label disp t pl)
(* and dispatch_record_label disp t pl =
try List.assoc (t,pl) !memo_dispatch_record
with Not_found ->
(* Format.fprintf Format.std_formatter "%a@\n"
Types.Print.print_descr (Types.Record.descr t);
dump_dr Format.std_formatter pl; *)
let r = dispatch_record_label' disp t pl in
incr memo_dr_count;
let r = !memo_dr_count, r in
memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;
r *)
and dispatch_record_label disp t pl =
match collect_first_label pl with
| None ->
......@@ -740,6 +795,11 @@ struct
List.map (conv_source_record catch) res in
`Result (return disp pl aux_final)
| Some l ->
let (plabs,absent) =
let pl = label_not_found l pl in
let t = Types.Record.restrict_label_absent t l in
pl, dispatch_record_opt disp t pl
in
let present =
let pl = label_found l pl in
let t = Types.Record.restrict_label_present t l in
......@@ -749,23 +809,23 @@ struct
List.map (fun (p, r) -> p, (res, catch, r)) d, []
| x -> [],[x])
(Types.Record.project_field t l)
(dispatch_record_field l disp t)
(dispatch_record_field l disp t plabs)
(fun x -> combine x)
in
let absent =
let pl = label_not_found l pl in
let t = Types.Record.restrict_label_absent t l in
dispatch_record_opt disp t pl
in
combine_record l present absent
and dispatch_record_field l disp t tfield pl others =
and dispatch_record_field l disp t plabs tfield pl others =
let t = Types.Record.restrict_field t l tfield in
let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in
let aux (ret, (res, catch, rem)) =
let catch = if ret = [] then catch else (l,ret) :: catch in
(res, catch, rem) in
let pl = Array.map (List.map aux) pl in
Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
if pl = plabs then `Absent else
(* TODO: Check that this is the good condition ....
Need condition on t ? *)
dispatch_record_label disp t pl
let actions disp =
match disp.actions with
| Some a -> a
......@@ -874,6 +934,7 @@ struct
Format.fprintf ppf " @[%a@]@\n" print_record r
and print_record ppf = function
| `Result r -> print_ret ppf r
| `Absent -> Format.fprintf ppf "Jump to Absent"
| `Label (l, present, absent) ->
let l = Types.label_name l in
Format.fprintf ppf "check label %s:@\n" l;
......@@ -916,8 +977,8 @@ struct
| [] -> ()
| d :: rem ->
to_print := rem;
Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
d.id Types.Print.print_descr (Types.normalize d.t);
(* Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
d.id Types.Print.print_descr (Types.normalize d.t); *)
let print_code code (t, arity, m) =
Format.fprintf ppf " Returns $%i(arity=%i) for [%a]"
code arity
......
......@@ -51,7 +51,8 @@ module Compile: sig
}
and record =
[ `Label of Types.label * record dispatch * record option
| `Result of result ]
| `Result of result
| `Absent ]
and 'a dispatch =
[ `Dispatch of dispatcher * 'a array
......
......@@ -2,6 +2,8 @@ open Recursive
open Printf
let map_sort f l =
SortedList.from_list (List.map f l)
type label = int
type atom = int
......@@ -660,7 +662,6 @@ struct
let line r = List.for_all (fun (l,(o,d)) -> o || non_empty d) r in
List.filter line (get_record d.record)
let restrict_label_present t l =
let restr = function
| (true, d) -> if non_empty d then (false,d) else raise Exit
......@@ -706,11 +707,16 @@ struct
match (n, r) with
| (`Success, _) | (_, []) -> `Success
| (`Fail, r) ->
let aux (l,(o,t)) n = `Label (l, [t,n], if o then n else `Fail) in
let aux (l,(o,t)) n =
`Label (l, [t,n], if o then n else `Fail) in
List.fold_right aux r `Success
| (`Label (l1,present,absent), (l2,(o,t2))::r') ->
if (l1 < l2) then
let pr = List.map (fun (t,x) -> (t, merge_record x r)) present in
let t = List.fold_left (fun a (t,_) -> diff a t) any present in
let pr =
if non_empty t then (t, merge_record `Fail r) :: pr
else pr in
`Label (l1,pr,merge_record absent r)
else if (l2 < l1) then
let n' = merge_record n r' in
......@@ -731,21 +737,84 @@ struct
let abs = if o then merge_record absent r' else absent in
`Label (l1, !res, abs)
module Unify = Map.Make(struct type t = normal let compare = compare end)
let repository = ref Unify.empty
let rec canonize = function
| `Label (l,pr,ab) as x ->
(try Unify.find x !repository
with Not_found ->
let pr = List.map (fun (t,n) -> canonize n,t) pr in
let pr = SortedMap.from_list cup pr in
let pr = List.map (fun (n,t) -> (t,n)) pr in
let x = `Label (l, pr, canonize ab) in
try Unify.find x !repository
with Not_found -> repository := Unify.add x x !repository; x
)
| x -> x
let normal d =
List.fold_left merge_record `Fail (get d)
let r = canonize (List.fold_left merge_record `Fail (get d)) in
repository := Unify.empty;
r
type normal' =
[ `Success
| `Label of label * (descr * descr) list * descr option ] option
(* NOTE: this function relies on the fact that generic order
makes smallest labels appear first *)
let first_label d =
let d = d.record in
let min = ref None in
let lab (l,o,t) = match !min with
| Some l' when l >= l' -> ()
| _ -> if o && (descr t = any) then () else min := Some l in
let line (p,n) =
(match p with f::_ -> lab f | _ -> ());
(match n with f::_ -> lab f | _ -> ()) in
List.iter line d;
match !min with
| None -> if d = [] then `Empty else `Any
| Some l -> `Label l
let normal' (d : descr) l =
let ab = ref empty in
let rec extract f = function
| (l',o,t) :: rem when l = l' ->
f o (descr t); extract f rem
| x :: rem -> x :: (extract f rem)
| [] -> [] in
let line (p,n) =
let ao = ref true and ad = ref any in
let p =
extract (fun o d -> ao := !ao && o; ad := cap !ad d) p
and n =
extract (fun o d -> ao := !ao && not o; ad := diff !ad d) n
in
(* Note: p and n are still sorted *)
let d = { empty with record = [(p,n)] } in
if !ao then ab := cup d !ab;
(!ad, d) in
let pr = List.map line d.record in
let pr = Product.normal_aux pr in
let ab = if is_empty !ab then None else Some !ab in
(pr, ab)
let any = { empty with record = any.record }
let is_empty d = d = []
let descr l =
let line l = map_sort (fun (l,(o,d)) -> (l,o,cons d)) l, [] in
{ empty with record = map_sort line l }
end
let memo_normalize = ref DescrMap.empty
let map_sort f l =
SortedList.from_list (List.map f l)
let rec rec_normalize d =
try DescrMap.find d !memo_normalize
......
......@@ -97,8 +97,9 @@ module Record : sig
val any : descr
(* List of maps label -> (optional, content) *)
type t = (label, (bool * descr)) SortedMap.t list
type t (* = (label, (bool * descr)) SortedMap.t list *)
val get: descr -> t
val descr: t -> descr
val is_empty: t -> bool
val restrict_label_present: t -> label -> t
val restrict_field: t -> label -> descr -> t
......@@ -109,8 +110,12 @@ module Record : sig
[ `Success
| `Fail
| `Label of label * (descr * normal) list * normal ]
val normal: descr -> normal
val normal': descr -> label -> (descr * descr) list * descr option
val first_label: descr -> [ `Empty | `Any | `Label of label ]
val project : descr -> label -> descr
(* Raise Not_found if label is not necessarily present *)
end
......
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