patterns.ml 30 KB
Newer Older
1
2
3
type capture = string
type fv = capture SortedList.t

4
5
exception Error of string

6
7
8
9
10
11

(* Syntactic algebra *)

type d =
  | Constr of Types.node
  | Cup of descr * descr
12
  | Cap of descr * descr * bool
13
  | Times of node * node
14
  | Xml of node * node
15
16
17
18
19
20
21
22
23
24
  | 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

25
26
27
28
29
let counter = State.ref "Patterns.counter" 0

let make fv =
  incr counter;
  { id = !counter; descr = None; accept = Types.make (); fv = fv }
30
31
32
33
34
35
36
37

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) = 
38
39
40
41
42
43
44
45
46
47
  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"))
  );
48
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
49
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e = 
50
51
52
53
54
55
56
57
58
  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
  );
59
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
60
61
let times x y =
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
62
63
let xml x y =
  (Types.xml x.accept y.accept, SortedList.cup x.fv y.fv, Xml (x,y))
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
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)
97
      | Cap (d1,d2,true) ->
98
	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
99
100
      | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->
	  SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)
101
102
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
103
104
105
106
107
108
109
      | 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))]

110
111
112
113
114
115
116
117
118
119
120
121
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)


122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
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 *)

141
module Normal = 
142
143
144
145
146
147
148
149
150
151
152
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

153
  type 'a line = (result * 'a, Types.descr) sm
154
155
  type nf = {
    v     : fv;
156
    catchv: fv;  (* Variables catching the value *)
157
    a     : Types.descr;
158
159
    basic : unit line;
    prod  : (node sl * node sl) line;
160
161
162
    xml   : (node sl * node sl) line;
    record: ((Types.label, node sl) sm) line;

163
164
165
166
167
168
169
170
  }

  type 'a nline = (result *  'a) list
  type record =
      [ `Success
      | `Fail
      | `Dispatch of (nf * record) list
      | `Label of Types.label * (nf * record) list * record ]
171
  type t = {
172
    nfv    : fv;
173
    ncatchv: fv;
174
    na     : Types.descr;
175
176
    nbasic : Types.descr nline;
    nprod  : (nf * nf) nline;
177
    nxml   : (nf * nf) nline;
178
    nrecord: record nline
179
180
  }

181
182
  let empty = { v = []; catchv = []; 
		a = Types.empty; 
183
184
185
186
187
		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])
188
  let restrict t nf =
189
190
191
192
193
194
    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
195
    {  v = nf.v;
196
       catchv = nf.catchv;
197
       a = Types.cap t nf.a;
198
199
       basic = filter nf.basic;
       prod = filter nf.prod;
200
       xml = filter nf.xml;
201
       record = filter nf.record;
202
203
204
205
206
207
    }

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

  let cap nf1 nf2 =
208
209
210
211
212
213
214
215
216
217
218
219
220
221
    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 () () = ()
222
    and merge_prod (p1,q1) (p2,q2) = slcup p1 p2, slcup q1 q2
223
    and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
224
    { v = SortedList.cup nf1.v nf2.v;
225
      catchv = SortedList.cup nf1.catchv nf2.catchv;
226
      a = Types.cap nf1.a nf2.a;
227
228
      basic = merge merge_basic nf1.basic nf2.basic;
      prod = merge merge_prod nf1.prod nf2.prod;
229
      xml = merge merge_prod nf1.xml nf2.xml;
230
      record = merge merge_record nf1.record nf2.record;
231
232
233
234
235
236
    }


		  
  let cup acc1 nf1 nf2 =
    let nf2 = restrict (Types.neg acc1) nf2 in
237
    { v = nf1.v; (* = nf2.v *)
238
      catchv = SortedList.cap nf1.catchv nf2.catchv;
239
240
      a = Types.cup nf1.a nf2.a;
      basic = SortedMap.union Types.cup nf1.basic nf2.basic;
241
      prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
242
      xml   = SortedMap.union Types.cup nf1.xml nf2.xml;
243
      record = SortedMap.union Types.cup nf1.record nf2.record;
244
245
246
247
248
249
250
251
252
    }

  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;
253
	prod = [ (src, ([p], [q])), acc ] }
254

255
256
257
258
259
260
261
262
263
  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 ] }

264
265
266
267
268
  let record acc l p =
    let src = List.map (fun v -> (v, `Field l)) p.fv in
    { empty with
	v = p.fv;
	a = acc;
269
	record = [ (src, [l,[p]]), acc ] }
270
271

  let any =
272
273
    { v = []; 
      catchv = [];
274
      a = Types.any;
275
276
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
277
      xml   = [ ([],([],[])), Types.Product.any_xml ];
278
      record = [ ([],[]), Types.Record.any ];
279
280
281
282
283
    }

  let capture x =
    let l = [x,`Catch] in
    { v = [x];
284
      catchv = [x];
285
      a = Types.any;
286
287
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
288
      xml  = [ (l,([],[])), Types.Product.any_xml  ];
289
      record = [ (l,[]), Types.Record.any ];
290
291
292
293
294
    }

  let constant x c =
    let l = [x,`Const c] in
    { v = [x];
295
      catchv = [];
296
      a = Types.any;
297
298
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
299
      xml   = [ (l,([],[])), Types.Product.any_xml  ];
300
      record = [ (l,[]), Types.Record.any ];
301
302
303
304
    }

  let constr t =
    { v = [];
305
      catchv = [];
306
      a = t;
307
308
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
309
      xml   = [ ([],([],[])), Types.cap t Types.Product.any_xml ];
310
      record = [ ([],[]), Types.cap t Types.Record.any ];
311
312
313
314
315
316
317
318
    }

(* 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)
319
      | Cap (p,q,_) -> cap (nf p) (nf q)
320
321
      | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
      | Times (p,q) -> times acc p q
322
      | Xml (p,q) -> xml acc p q
323
324
325
326
327
328
      | 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

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

333
    and prod ?kind l =
334
335
336
      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
337
	let t = Types.Product.normal ?kind acc in
338
	List.fold_left aux accu t in
339
      List.fold_left line [] l
340
   
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356

    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),_) ->
357
	      let aux_ab = aux ab fields in
358
	      let pr = 
359
360
361
362
363
364
		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)
365
366
367
368
369
370
371
372
373
374
      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
375
376
377
378
    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;
379
      na      = nf.a;
380
381
      nbasic  = nlines (basic nf.basic);
      nprod   = nlines (prod nf.prod);
382
      nxml    = nlines (prod ~kind:`XML nf.xml);
383
      nrecord = nlines (record nf.record);
384
    }
385

386
end
387
388


389
390
module Compile = 
struct
391
392
393
394
  type actions =
      [ `Ignore of result
      | `Kind of actions_kind ]
  and actions_kind = {
395
396
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
397
    xml: result dispatch dispatch;
398
399
400
401
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
402
403
      | `Result of result
      | `Absent ]
404
      
405
406
407
408
409
410
411
  and 'a dispatch =
      [ `Dispatch of dispatcher * 'a array
      | `TailCall of dispatcher
      | `Ignore of 'a
      | `None ]

  and result = int * source array
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
  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
  }
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449

  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

450
  let combine_kind basic prod xml record =
451
452
453
454
455
456
457
458
459
460
    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
461
462
463
464
      let rs = match xml with
	| `None -> rs
	| `Ignore (`Ignore r) -> r :: rs
	| _ -> raise Exit in
465
466
467
468
469
      let rs = match record with
	| None -> rs
	| Some (`Result r) -> r :: rs
	| _ -> raise Exit in
      match rs with
470
471
472
473
474
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
	      (function `Catch | `Const _ -> true | _ -> false) ret
	    -> `Ignore r
475
476
	| _ -> raise Exit
    )
477
    with Exit -> `Kind { basic = basic; prod = prod; xml = xml; record = record }
478

479
  let combine (disp,act) =
480
481
482
483
484
485
486
487
488
489
490
    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
491
      | (`Ignore `Absent, Some r) -> r
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
      | (`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
   
529
530
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
531
		 
532
533
  module DispMap = Map.Make(
    struct
534
      type t = Types.descr * Normal.t array
535
536
537
      let compare = compare
    end
  )
538
    
539
  let dispatchers = ref DispMap.empty
540
541
		      
  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
542

543
    
544
545
546
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
547
548
549
550
      let nb = ref 0 in
      let rec aux t arity i = 
	if Types.is_empty t then `None
	else
551
	  if i = Array.length pl 
552
	  then (incr nb; `Result (!nb - 1, t, arity))
553
554
	  else
	    let p = pl.(i) in
555
556
	    let tp = p.Normal.na in
	    let v = p.Normal.nfv in
557
558
559
560
561
562
563
564
565

	    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;
*)
	    
566
(*	    let tp = Types.normalize tp in *)
567
568
569
570
571
572
573
574
575
576
577
578
	    `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
579
580
	| `Result (code,t,arity) -> 
	    codes.(code) <- (t,arity, accu)
581
      in
582
      aux 0 [] iface;
583
584
585
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
586
587
		  interface = iface;
		  codes = codes;
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
		  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

603
604
605
  let find_code d a =
    let rec aux i = function
      | `Result (code,_,_) -> code
606
607
      | `None -> 
	  assert false
608
609
610
611
612
613
      | `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 =
614
615
616
617
618
619
620
    Array.of_list (
      Array.fold_right
		     (fun x accu -> match x with
			| Some b -> b @ accu 
			| None -> accu)
		     pl []
    )
621
622
623
624
625
626
627

  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
628
629
630
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

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

634
635
  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
636
637
638
    | `Left -> `Left (assoc v left)
    | `Right -> `Right (assoc v right)
    | `Recompose -> `Recompose (assoc v left, assoc v right)
639
    | _ -> assert false
640

641
642
  let conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
643
    | `Field l -> `Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
644
645
646
647
648
649
650
651
652
653
654
655
    | _ -> 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
656
    let accu = ref [] in
657
    let rec aux (success : (int * Normal.result) list) t l = 
658
659
660
      if Types.non_empty t 
      then match l with
	| [] ->
661
662
663
664
665
666
667
668
669
	    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
670
    in
671
    aux [] t tests;
672
673
674
    !accu


675
  let get_tests pl f t d post =
676
677
678
679
680
    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) ->
681
682
683
		   let p = Normal.restrict t p in
		   let p = Normal.normal p in
		   accu := (p,[i, info]) :: !accu;
684
685
686
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
687

688
689
690
    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
691
    let result (t,_,m) =
692
693
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
694
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
695
696
      d t selected unselect
    in
697
    let res = Array.map result disp.codes in
698
699
    post (disp,res)

700

701
702
703
704
705
706
  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
707
	   (t, (p,(p.Normal.catchv,e)) :: brs)
708
	) (t,[]) brs in
709
	
710
711
712
713
714
715
716
717
    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 
718
719
720
	   | [(res,(catchv,e))] -> assert (!r = None); 
	       let catchv = List.map (fun v -> (v,-1)) catchv in
	       r := Some (SortedMap.union_disj catchv res,e)
721
722
723
724
725
726
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
727
728


729
730
731
732
733
734
735
  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
736
737
738
739
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
740
      (fun x -> detect_left_tail_call (combine x))
741
742
743
744
745
746
  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)
747
      (fun x -> detect_right_tail_call (combine x))
748
  and dispatch_prod2 disp t t2 pl _ =
749
750
751
    let aux_final (ret2, (ret1, res)) =  
      List.map (conv_source_prod ret1 ret2) res in
    return disp pl aux_final
752
753


754
  let dummy_label = Types.LabelPool.dummy_max
755
756
757
758

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
759
      | (res, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
760
761
      | _ -> () in
    Array.iter (List.iter aux) pl;
762
    if !m = dummy_label then None else Some !m
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782

  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)

783
(*
784
785
  let memo_dispatch_record = ref []
  let memo_dr_count = ref 0
786
*)
787
788
789
790
791

  let rec print_normal_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Label (l,pr,ab) ->
792
	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
	   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) -> 
810
			   Format.fprintf ppf "%s[" (Types.LabelPool.value l);
811
812
813
814
815
816
817
818
819
			   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

820
  let rec dispatch_record disp : record option =
821
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
822
823
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
824
    let r = dispatch_record_opt disp t pl0 in
825
(*    memo_dispatch_record := []; *)
826
    r
827
828
829
  and dispatch_record_opt disp t pl =
    if Types.Record.is_empty t then None 
    else Some (dispatch_record_label disp t pl)
830
831
832
833
834
835
836
837
838
839
840
(*  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 *)
841
842
843
  and dispatch_record_label disp t pl =
    match collect_first_label pl with
      | None -> 
844
845
846
847
	  let aux_final (res, catch, x) =
	    assert (x = `Success);
	    List.map (conv_source_record catch) res in
	  `Result (return disp pl aux_final)
848
      | Some l ->
849
850
851
852
853
	  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
854
855
856
857
858
859
860
861
862
	  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)
863
	      (dispatch_record_field l disp t plabs)
864
	      (fun x -> combine x)
865
	  in
866
	  combine_record l present absent
867
  and dispatch_record_field l disp t plabs tfield pl others =
868
    let t = Types.Record.restrict_field t l tfield in
869
870
871
    let aux (ret, (res, catch, rem)) = 
      let catch = if ret = [] then catch else (l,ret) :: catch in
      (res, catch, rem) in
872
873
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
874
(*    if pl = plabs then `Absent else  *)
875
      (* TODO: Check that this is the good condition ....
876
877
878
879
880
881
882
883
884
	 Need condition on t ?

	 No, it isn't a good condition:
	 match { x = "a" } : { x =? "a"|"b" } with
	 | { x = "b" } -> 1
	 | _  -> 0;;
	 Need to investigate ....
      *)
	 
885
886
    dispatch_record_label disp t pl
    
887
      
888
889
890
891
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
892
893
894
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
895
		    (dispatch_prod ~kind:`XML disp)
896
897
		    (dispatch_record disp)
	  in
898
899
900
901
902
903
904
905
906
907
908
909
	  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
    )

910
  let rec print_source ppf = function
911
912
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
913
914
    | `Left (-1) -> Format.fprintf ppf "v1"
    | `Right (-1) -> Format.fprintf ppf "v2"
915
    | `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
916
917
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
918
919
920
921
    | `Recompose (i,j) -> 
	Format.fprintf ppf "(%a,%a)" 
	  print_source (`Left i)
	  print_source (`Right j)
922
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i
923
924
925
926
927
928
929
930
931
932
933
934
935
936

  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 =
937
    let print_lhs ppf (code,prefix,d) =
938
      let arity = match d.codes.(code) with (_,a,_) -> a in
939
940
941
942
943
944
945
      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) =
946
      Format.fprintf ppf " | %a -> %a@\n"
947
948
949
	Types.Print.print_descr t
	print_ret ret
    in
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
    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
968
    in
969
    let print_prod prefix = function
970
971
      | `None -> ()
      | `Ignore d2 ->
972
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
973
974
975
	  print_prod2 d2
      | `TailCall d ->
	  queue d;
976
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
977
978
979
	  Format.fprintf ppf "      disp_%i v1@\n" d.id
      | `Dispatch (d,branches) ->
	  queue d;
980
	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
981
982
983
984
985
986
987
988
	  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
989
990
991
992
993
994
995
996
    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
997
      | `Absent -> Format.fprintf ppf "Jump to Absent"
998
      | `Label (l, present, absent) ->
999
	  let l = Types.LabelPool.value l in
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
	  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 ->
1010
	  queue d;
1011
1012
1013
1014
	  Format.fprintf ppf "disp_%i@\n" d.id 
      | `Dispatch (d,branches) ->
	  queue d;
	  Format.fprintf ppf "match with disp_%i@\n" d.id;
1015
1016
	  Array.iteri
	    (fun code r ->
1017
	       Format.fprintf ppf "| %a -> @\n"
1018
	         print_lhs (code, l, d);
1019
	       Format.fprintf ppf "   @[%a@]@\n"
1020
	         print_record r
1021
1022
1023
1024
	    ) branches
      | `Ignore r ->
	  Format.fprintf ppf "@[%a@]@\n"
	    print_record r
1025
1026
1027
    in
    
    List.iter print_basic actions.basic;
1028
1029
    print_prod "" actions.prod;
    print_prod "XML" actions.xml;
1030
1031
    print_record_opt ppf actions.record

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

1036
1037
1038
1039
1040
  let rec print_dispatchers ppf =
    match !to_print with
      | [] -> ()
      | d :: rem ->
	  to_print := rem;
1041
1042
(*	  Format.fprintf ppf "Dispatcher %i accepts [%a]@\n" 
	    d.id Types.Print.print_descr (Types.normalize d.t); *)
1043
1044
1045
	  let print_code code (t, arity, m) =
	    Format.fprintf ppf "  Returns $%i(arity=%i) for [%a]" 
	      code arity
1046
	      Types.Print.print_descr (Types.normalize t);
1047

1048
1049
1050
	       List.iter
	       (fun (i,b) ->
		      Format.fprintf ppf "[%i:" i;
1051
1052
1053
		      List.iter 
			(fun (v,i) ->  Format.fprintf ppf "%s=>%i;" v i)
			b;
1054
		      Format.fprintf ppf "]"
1055
	       ) m; 
1056

1057
1058
	       Format.fprintf ppf "@\n";
	  in
1059
(*	  Array.iteri print_code d.codes;  *)
1060
	  Format.fprintf ppf "let disp_%i = function@\n" d.id;
1061
	  print_actions ppf (actions d);
1062
	  Format.fprintf ppf "====================================@\n";
1063
1064
1065
1066
1067
1068
1069
	  print_dispatchers ppf

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

1070
1071
  type normal = Normal.t
  let normal p = Normal.normal (Normal.nf p)
1072

1073
end
1074
1075