patterns.ml

type capture = string
type fv = capture SortedList.t

exception Error of string


(* Syntactic algebra *)

type d =
  | Constr of Types.node
  | Cup of descr * descr
  | Cap of descr * descr * bool
  | Times of node * node
  | Xml of node * node
  | Record of Types.label * node
  | Capture of capture
  | Constant of capture * Types.const
and node = {
  id : int;
  mutable descr : descr option;
  accept : Types.node;
  fv : fv
} and descr = Types.descr * fv * d

let counter = State.ref "Patterns.counter" 0

let make fv =
  incr counter;
  { id = !counter; descr = None; accept = Types.make (); fv = fv }

let define x ((accept,fv,_) as d) =
  assert (x.fv = fv);
  Types.define x.accept accept;
  x.descr <- Some d

let constr x = (Types.descr x,[],Constr x)
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
  if fv1 <> fv2 then (
    let x = match SortedList.diff fv1 fv2 with
      | x::_ -> x
      | [] -> match SortedList.diff fv2 fv1 with x::_ -> x | _ -> assert false
    in
    raise 
      (Error 
	 ("The capture variable " ^ x ^ 
	  " should appear on both side of this | pattern"))
  );
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e = 
  if not (SortedList.disjoint fv1 fv2) then (
    match SortedList.cap fv1 fv2 with
      | x::_ -> 
	  raise 
	  (Error 
	     ("The capture variable " ^ x ^ 
	      " cannot appear on both side of this & pattern"))
      | _ -> assert false
  );
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
let times x y =
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
let xml x y =
  (Types.xml x.accept y.accept, SortedList.cup x.fv y.fv, Xml (x,y))
let record l x = 
  (Types.record l false x.accept, x.fv, Record (l,x))
let capture x = (Types.any, [x], Capture x)
let constant x c = (Types.any, [x], Constant (x,c))


let id x = x.id
let descr x = match x.descr with Some d -> d | None -> failwith "Patterns.descr"
let fv x = x.fv
let accept x = Types.internalize x.accept


(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
let empty_res fv = List.map (fun v -> (v, Types.Positive.ty Types.empty)) fv
let times_res v1 v2 = Types.Positive.times v1 v2

module MemoFilter = Map.Make 
  (struct type t = Types.descr * node let compare = compare end)

let memo_filter = ref MemoFilter.empty

let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
      | Constr _ -> []
      | Cup ((a,_,_) as d1,d2) ->
	  SortedMap.union cup_res
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
      | Cap (d1,d2,true) ->
	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
      | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->
	  SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
	  [(c, Types.Positive.ty t)]
      | Constant (c, cst) ->
	  [(c, Types.Positive.ty (Types.constant cst))]

and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
	 SortedMap.union times_res (filter_node d1 p1) (filter_node d2 p2)
       in
       SortedMap.union cup_res accu term
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
    let (_,fv,_) as d = descr p in
    let res = List.map (fun v -> (v,Types.Positive.forward ())) fv in
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
    List.iter2 (fun (_,r) (_,v) -> Types.Positive.define v r) r res;
    r

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
  List.map (fun (c,v) -> (c,Types.Positive.solve v)) r



(* Normal forms for patterns and compilation *)

module Normal = 
struct
  type 'a sl = 'a SortedList.t
  type ('a,'b) sm = ('a,'b) SortedMap.t

  type source = 
      [ `Catch | `Const of Types.const 
      | `Left | `Right | `Recompose 
      | `Field of Types.label 
      ]
  type result = (capture, source) sm

  type 'a line = (result * 'a, Types.descr) sm
  type nf = {
    v     : fv;
    catchv: fv;  (* Variables catching the value *)
    a     : Types.descr;
    basic : unit line;
    prod  : (node sl * node sl) line;
    xml   : (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 t = {
    nfv    : fv;
    ncatchv: fv;
    na     : Types.descr;
    nbasic : Types.descr nline;
    nprod  : (nf * nf) nline;
    nxml   : (nf * nf) nline;
    nrecord: record nline
  }

  let empty = { v = []; catchv = []; 
		a = Types.empty; 
		basic = []; prod = []; xml = []; record = [] }
  let any_basic = Types.neg (List.fold_left Types.cup Types.empty
			       [Types.Product.any_xml;
				Types.Product.any;
				Types.Record.any])
  let restrict t nf =
    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;
       catchv = nf.catchv;
       a = Types.cap t nf.a;
       basic = filter nf.basic;
       prod = filter nf.prod;
       xml = filter nf.xml;
       record = filter nf.record;
    }

  let fus = SortedMap.union_disj
  let slcup = SortedList.cup

  let cap nf1 nf2 =
    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 p2, slcup q1 q2
    and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
    { v = SortedList.cup nf1.v nf2.v;
      catchv = SortedList.cup nf1.catchv nf2.catchv;
      a = Types.cap nf1.a nf2.a;
      basic = merge merge_basic nf1.basic nf2.basic;
      prod = merge merge_prod nf1.prod nf2.prod;
      xml = merge merge_prod nf1.xml nf2.xml;
      record = merge merge_record nf1.record nf2.record;
    }


		  
  let cup acc1 nf1 nf2 =
    let nf2 = restrict (Types.neg acc1) nf2 in
    { v = nf1.v; (* = nf2.v *)
      catchv = SortedList.cap nf1.catchv nf2.catchv;
      a = Types.cup nf1.a nf2.a;
      basic = SortedMap.union Types.cup nf1.basic nf2.basic;
      prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
      xml   = SortedMap.union Types.cup nf1.xml nf2.xml;
      record = SortedMap.union Types.cup nf1.record nf2.record;
    }

  let times acc p q = 
    let src_p = List.map (fun v -> (v,`Left)) p.fv
    and src_q = List.map (fun v -> (v,`Right)) q.fv in
    let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in 
    { empty with 
	v = SortedList.cup p.fv q.fv; 
	a = acc;
	prod = [ (src, ([p], [q])), acc ] }

  let xml acc p q = 
    let src_p = List.map (fun v -> (v,`Left)) p.fv
    and src_q = List.map (fun v -> (v,`Right)) q.fv in
    let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in 
    { empty with 
	v = SortedList.cup p.fv q.fv; 
	a = acc;
	xml = [ (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, [l,[p]]), acc ] }

  let any =
    { v = []; 
      catchv = [];
      a = Types.any;
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
      xml   = [ ([],([],[])), Types.Product.any_xml ];
      record = [ ([],[]), Types.Record.any ];
    }

  let capture x =
    let l = [x,`Catch] in
    { v = [x];
      catchv = [x];
      a = Types.any;
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      xml  = [ (l,([],[])), Types.Product.any_xml  ];
      record = [ (l,[]), Types.Record.any ];
    }

  let constant x c =
    let l = [x,`Const c] in
    { v = [x];
      catchv = [];
      a = Types.any;
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      xml   = [ (l,([],[])), Types.Product.any_xml  ];
      record = [ (l,[]), Types.Record.any ];
    }

  let constr t =
    { v = [];
      catchv = [];
      a = t;
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
      xml   = [ ([],([],[])), Types.cap t Types.Product.any_xml ];
      record = [ ([],[]), Types.cap t Types.Record.any ];
    }

(* Put a pattern in normal form *)
  let rec nf (acc,fv,d) =
    if Types.is_empty acc 
    then empty
    else match d with
      | Constr t -> constr (Types.descr t)
      | Cap (p,q,_) -> cap (nf p) (nf q)
      | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
      | Times (p,q) -> times acc p q
      | Xml (p,q) -> xml acc p q
      | Capture x -> capture x
      | Constant (x,c) -> constant x c
      | Record (l,p) -> record acc l p

  let bigcap = List.fold_left (fun a p -> cap a (nf (descr p))) any

  let normal nf =
    let basic =
      List.map (fun ((res,()),acc) -> (res,acc)) 

    and prod ?kind l =
      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
	let t = Types.Product.normal ?kind acc in
	List.fold_left aux accu t in
      List.fold_left line [] l
   

    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 aux_ab = aux ab fields in
	      let pr = 
		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) =
	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
    let nlines l = 
      List.map (fun (res,x) -> (SortedMap.diff res nf.catchv,x)) l in
    { nfv     = SortedList.diff nf.v nf.catchv; 
      ncatchv = nf.catchv;
      na      = nf.a;
      nbasic  = nlines (basic nf.basic);
      nprod   = nlines (prod nf.prod);
      nxml    = nlines (prod ~kind:`XML nf.xml);
      nrecord = nlines (record nf.record);
    }

end


module Compile = 
struct
  type actions =
      [ `Ignore of result
      | `Kind of actions_kind ]
  and actions_kind = {
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
    xml: result dispatch dispatch;
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
      | `Result of result
      | `Absent ]
      
  and 'a dispatch =
      [ `Dispatch of dispatcher * 'a array
      | `TailCall of dispatcher
      | `Ignore of 'a
      | `None ]

  and result = int * source array
  and source = 
      [ `Catch | `Const of Types.const 
      | `Left of int | `Right of int | `Recompose of int * int
      | `Field of Types.label * int
      ]
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
      (int * (capture, int) SortedMap.t) list

  and interface =
    [ `Result of int * Types.descr * int  (* code, accepted type, arity *)
    | `Switch of (capture, int) SortedMap.t * interface * interface
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
    interface : interface;
    codes : return_code array;
    mutable actions : actions option
  }

  let array_for_all f a =
    let rec aux f a i =
      if i = Array.length a then true
      else f a.(i) && (aux f a (succ i))
    in
    aux f a 0

  let array_for_all_i f a =
    let rec aux f a i =
      if i = Array.length a then true
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

  let combine_kind basic prod xml record =
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
	| `None -> rs
	| `Ignore (`Ignore r) -> r :: rs
	| _ -> raise Exit in
      let rs = match xml with
	| `None -> rs
	| `Ignore (`Ignore r) -> r :: rs
	| _ -> raise Exit in
      let rs = match record with
	| None -> rs
	| Some (`Result r) -> r :: rs
	| _ -> raise Exit in
      match rs with
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
	      (function `Catch | `Const _ -> true | _ -> false) ret
	    -> `Ignore r
	| _ -> raise Exit
    )
    with Exit -> `Kind { basic = basic; prod = prod; xml = xml; record = record }

  let combine (disp,act) =
    if Array.length act = 0 then `None
    else
      if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes) 
	 && (array_for_all ( (=) act.(0) ) act) then
	   `Ignore act.(0)
      else
	`Dispatch (disp, act)

  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)

  let detect_right_tail_call = function
    | `Dispatch (disp,branches) 
	when
	  array_for_all_i
	    (fun i (code,ret) ->
	       (i = code) && 
	       (array_for_all_i 
		  (fun pos -> 
		     function `Right j when pos = j -> true | _ -> false)
		  ret
	       )
	    ) branches
	  -> `TailCall disp
    | x -> x

  let detect_left_tail_call = function
    | `Dispatch (disp,branches)
	when
	  array_for_all_i
	    (fun i -> 
	       function 
		 | `Ignore (code,ret) ->
		     (i = code) &&
		     (array_for_all_i 
			(fun pos -> 
			   function `Left j when pos = j -> true | _ -> false)
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
	 `TailCall disp
    | x -> x
   
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
		 
  module DispMap = Map.Make(
    struct
      type t = Types.descr * Normal.t array
      let compare = compare
    end
  )
    
  let dispatchers = ref DispMap.empty
		      
  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)

    
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
      let nb = ref 0 in
      let rec aux t arity i = 
	if Types.is_empty t then `None
	else
	  if i = Array.length pl 
	  then (incr nb; `Result (!nb - 1, t, arity))
	  else
	    let p = pl.(i) in
	    let tp = p.Normal.na in
	    let v = p.Normal.nfv in

	    let v = SortedList.diff v p.Normal.ncatchv in
(*
	    Printf.eprintf "ncatchv = (";
	    List.iter (fun s -> Printf.eprintf "%s;" s) p.Normal.ncatchv;
	    Printf.eprintf ")\n";
	    flush stderr;
*)
	    
(*	    let tp = Types.normalize tp in *)
	    `Switch 
	      (num arity v,
	       aux (Types.cap t tp) (arity + (List.length v)) (i+1),
	       aux (Types.diff t tp) arity (i+1)
	      )
      in
      let iface = aux t 0 0 in
      let codes = Array.create !nb (Types.empty,0,[]) in
      let rec aux i accu = function
	| `None -> ()
	| `Switch (pos, yes, no) -> 
	    aux (i + 1) ((i,pos) :: accu) yes; aux (i + 1) accu no
	| `Result (code,t,arity) -> 
	    codes.(code) <- (t,arity, accu)
      in
      aux 0 [] iface;
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
		  interface = iface;
		  codes = codes;
		  actions = None } in
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
  let compare_masks a1 a2 =
    try
      for i = 0 to Array.length a1 - 1 do
	match a1.(i),a2.(i) with   
	  | None,Some _| Some _, None -> raise Exit
	  | _ -> ()
      done;
      true
    with Exit -> false

  let find_code d a =
    let rec aux i = function
      | `Result (code,_,_) -> code
      | `None -> 
	  assert false
      | `Switch (_,yes,no) ->
	  match a.(i) with Some _ -> aux (i + 1) yes | None -> aux (i + 1) no
    in
    aux 0 d.interface

  let create_result pl =
    Array.of_list (
      Array.fold_right
		     (fun x accu -> match x with
			| Some b -> b @ accu 
			| None -> accu)
		     pl []
    )

  let return disp pl f =
    let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
    let final = Array.map aux pl in
    (find_code disp final, create_result final)
    
  let conv_source_basic (v,s) = match s with
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

  let assoc v l =
    try List.assoc v l with Not_found -> -1

  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
    | `Left -> `Left (assoc v left)
    | `Right -> `Right (assoc v right)
    | `Recompose -> `Recompose (assoc v left, assoc v right)
    | _ -> assert false

  let conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
    | `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
    | _ -> assert false


  let dispatch_basic disp : (Types.descr * result) list =
    let pl = Array.map (fun p -> p.Normal.nbasic) disp.pl in
    let tests =
      let accu = ref [] in
      let aux i (res,x) = accu := (x, [i,res]) :: !accu in
      Array.iteri (fun i -> List.iter (aux i)) pl;
      SortedMap.from_list SortedList.cup !accu in

    let t = Types.cap Normal.any_basic disp.t in
    let accu = ref [] in
    let rec aux (success : (int * Normal.result) list) t l = 
      if Types.non_empty t 
      then match l with
	| [] ->
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
	    let aux_final res = List.map conv_source_basic res in
	    accu := (t, return disp selected aux_final) :: !accu
	| (ty,i) :: rem -> 
	    aux (i @ success) (Types.cap t ty) rem; 
	    aux success (Types.diff t ty) rem
    in
    aux [] t tests;
    !accu


  let get_tests pl f t d post =
    let accu = ref [] in
    let unselect = Array.create (Array.length pl) [] in
    let aux i x = 
      let yes, no = f x in
      List.iter (fun (p,info) ->
		   let p = Normal.restrict t p in
		   let p = Normal.normal p in
		   accu := (p,[i, info]) :: !accu;
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;

    let sorted = Array.of_list (SortedMap.from_list SortedList.cup !accu) in
    let infos = Array.map snd sorted in
    let disp = dispatcher t (Array.map fst sorted) in
    let result (t,_,m) =
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
      d t selected unselect
    in
    let res = Array.map result disp.codes in
    post (disp,res)


  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
	   let p = Normal.restrict t (Normal.nf p) in
	   let t = Types.diff t (p.Normal.a) in
	   (t, (p,(p.Normal.catchv,e)) :: brs)
	) (t,[]) brs in
	
    let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
    get_tests 
      pl 
      (fun x -> [x],[])
      t
      (fun _ pl _ ->
	 let r = ref None in
	 let aux = function 
	   | [(res,(catchv,e))] -> assert (!r = None); 
	       let catchv = List.map (fun v -> (v,-1)) catchv in
	       r := Some (SortedMap.union_disj catchv res,e)
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)


  let rec dispatch_prod ?(kind=`Normal) disp =
    let pl = 
      match kind with
	| `Normal ->  Array.map (fun p -> p.Normal.nprod) disp.pl
	| `XML -> Array.map (fun p -> p.Normal.nxml) disp.pl
    in
    let t = Types.Product.get ~kind disp.t in
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
      (fun x -> detect_left_tail_call (combine x))
  and dispatch_prod1 disp t t1 pl _ =
    let t = Types.Product.restrict_1 t t1 in
    get_tests pl
      (fun (ret1, (res,q)) -> [q, (ret1,res)], [] ) 
      (Types.Product.pi2 t)
      (dispatch_prod2 disp t)
      (fun x -> detect_right_tail_call (combine x))
  and dispatch_prod2 disp t t2 pl _ =
    let aux_final (ret2, (ret1, res)) =  
      List.map (conv_source_prod ret1 ret2) res in
    return disp pl aux_final


  let dummy_label = Types.LabelPool.dummy_max

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
      | (res, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
      | _ -> () in
    Array.iter (List.iter aux) pl;
    if !m = dummy_label then None else Some !m

  let map_record f = 
    let rec aux = function
      | [] -> []
      | h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in
    Array.map aux

  let label_found l = 
    map_record 
      (function
	 | (res, catch, `Label (l1, pr, _)) when l1 = l -> 
	     (res, catch, `Dispatch pr)
	 | x -> x)

  let label_not_found l = 
    map_record 
      (function
	 | (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.LabelPool.value 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.LabelPool.value 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
    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 -> 
	  let aux_final (res, catch, x) =
	    assert (x = `Success);
	    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
	    get_tests pl
	      (function 
		 | (res,catch, `Dispatch d) -> 
		     List.map (fun (p, r) -> p, (res, catch, r)) d, []
		 | x -> [],[x])
	      (Types.Record.project_field t l)
	      (dispatch_record_field l disp t plabs)
	      (fun x -> combine x)
	  in
	  combine_record l present absent
  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)) = 
      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
      | None ->
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
		    (dispatch_prod ~kind:`XML disp)
		    (dispatch_record disp)
	  in
	  disp.actions <- Some a;
	  a

  let to_print = ref []
  let printed = ref []

  let queue d =
    if not (List.mem d.id !printed) then (
      printed := d.id :: !printed;
      to_print := d :: !to_print
    )

  let rec print_source ppf = function
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
    | `Left (-1) -> Format.fprintf ppf "v1"
    | `Right (-1) -> Format.fprintf ppf "v2"
    | `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
    | `Recompose (i,j) -> 
	Format.fprintf ppf "(%a,%a)" 
	  print_source (`Left i)
	  print_source (`Right j)
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i

  let print_result ppf =
    Array.iteri 
      (fun i s ->
	 if i > 0 then Format.fprintf ppf ",";
	 print_source ppf s; 
      )

  let print_ret ppf (code,ret) = 
    Format.fprintf ppf "$%i" code;
    if Array.length ret <> 0 then 
      Format.fprintf ppf "(%a)" print_result ret

  let print_kind ppf actions =
    let print_lhs ppf (code,prefix,d) =
      let arity = match d.codes.(code) with (_,a,_) -> a in
      Format.fprintf ppf "$%i(" code;
      for i = 0 to arity - 1 do
	if i > 0 then Format.fprintf ppf ",";
	Format.fprintf ppf "%s%i" prefix i;
      done;
      Format.fprintf ppf ")" in
    let print_basic (t,ret) =
      Format.fprintf ppf " | %a -> %a@\n"
	Types.Print.print_descr t
	print_ret ret
    in
    let print_prod2 = function
      | `None -> assert false
      | `Ignore r ->
	  Format.fprintf ppf "        %a\n" 
	    print_ret r
      | `TailCall d ->
	  queue d;
	  Format.fprintf ppf "        disp_%i v2@\n" d.id
      | `Dispatch (d, branches) ->
	  queue d;
	  Format.fprintf ppf "        match v2 with disp_%i@\n" d.id;
	  Array.iteri 
	    (fun code r ->
	       Format.fprintf ppf "        | %a -> %a\n" 
	         print_lhs (code, "r", d)
	         print_ret r;
   	    )
	    branches
    in
    let print_prod prefix = function
      | `None -> ()
      | `Ignore d2 ->
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
	  print_prod2 d2
      | `TailCall d ->
	  queue d;
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
	  Format.fprintf ppf "      disp_%i v1@\n" d.id
      | `Dispatch (d,branches) ->
	  queue d;
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
	  Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;
	  Array.iteri 
	    (fun code d2 ->
               Format.fprintf ppf "      | %a -> @\n"
	       print_lhs (code, "l", d);
	       print_prod2 d2;
   	    )
	    branches
    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
      | `Result r -> print_ret ppf r
      | `Absent -> Format.fprintf ppf "Jump to Absent"
      | `Label (l, present, absent) ->
	  let l = Types.LabelPool.value l in
	  Format.fprintf ppf "check label %s:@\n" l;
	  Format.fprintf ppf "Present => @[%a@]@\n" (print_present l) present;
	  match absent with
	    | Some r ->
		Format.fprintf ppf "Absent => @[%a@]@\n"
		   print_record r
	    | None -> ()
    and print_present l ppf = function
      | `None -> assert false
      | `TailCall d ->
	  queue d;
	  Format.fprintf ppf "disp_%i@\n" d.id 
      | `Dispatch (d,branches) ->
	  queue d;
	  Format.fprintf ppf "match with disp_%i@\n" d.id;
	  Array.iteri
	    (fun code r ->
	       Format.fprintf ppf "| %a -> @\n"
	         print_lhs (code, l, d);
	       Format.fprintf ppf "   @[%a@]@\n"
	         print_record r
	    ) branches
      | `Ignore r ->
	  Format.fprintf ppf "@[%a@]@\n"
	    print_record r
    in
    
    List.iter print_basic actions.basic;
    print_prod "" actions.prod;
    print_prod "XML" actions.xml;
    print_record_opt ppf actions.record

  let print_actions ppf = function
    | `Kind k -> print_kind ppf k
    | `Ignore r -> Format.fprintf ppf "v -> %a@\n" print_ret r

  let rec print_dispatchers ppf =
    match !to_print with
      | [] -> ()
      | d :: rem ->
	  to_print := rem;
(*	  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
	      Types.Print.print_descr (Types.normalize t);

	       List.iter
	       (fun (i,b) ->
		      Format.fprintf ppf "[%i:" i;
		      List.iter 
			(fun (v,i) ->  Format.fprintf ppf "%s=>%i;" v i)
			b;
		      Format.fprintf ppf "]"
	       ) m; 

	       Format.fprintf ppf "@\n";
	  in
(*	  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";
	  print_dispatchers ppf

  let show ppf t pl =
    let disp = dispatcher t pl in
    queue disp;
    print_dispatchers ppf

  type normal = Normal.t
  let normal p = Normal.normal (Normal.nf p)

end