patterns.ml 29.2 KB
Newer Older
1
exception Error of string
2
open Ident
3

4
(* Syntactic algebra *)
5
(* Constraint: any node except Constr has fv<>[] ... *)
6
type d =
7
  | Constr of Types.descr
8
  | Cup of descr * descr
9
  | Cap of descr * descr
10
  | Times of node * node
11
  | Xml of node * node
12
  | Record of Types.label * node
13
14
  | Capture of id
  | Constant of id * Types.const
15
16
and node = {
  id : int;
17
18
  mutable descr : descr option;
  accept : Types.node;
19
  fv : fv
20
} and descr = Types.descr * fv * d
21

22
23
24
25
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
26
27
28

let printed = ref []
let to_print = ref []
29
30
let rec print ppf (a,_,d) = 
(*  Format.fprintf ppf "[%a]" Types.Print.print_descr a; *)
31
32
33
34
35
36
37
38
39
40
41
42
43
44
  match d with
    | Constr t -> Types.Print.print_descr ppf t
    | Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
    | Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
    | Times (n1,n2) -> 
	Format.fprintf ppf "(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Xml (n1,n2) -> 
	Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Record (l,n) -> 
	Format.fprintf ppf "{ %s =  P%i }" (Types.LabelPool.value l) n.id;
	to_print := n :: !to_print
    | Capture x ->
45
	Format.fprintf ppf "%s" (Id.value x)
46
    | Constant (x,c) ->
47
48
	Format.fprintf ppf "(%s := %a)" (Id.value x) 
	  Types.Print.print_const c
49

50
51
52
53
54
55
56
57
58
59
60
61
62
let dump_print ppf =
  while !to_print <> [] do
    let p = List.hd !to_print in
    to_print := List.tl !to_print;
    if not (List.mem p.id !printed) then
      ( printed := p.id :: !printed;
	Format.fprintf ppf "P%i:=%a\n" p.id print (descr p)
      )
  done

let print ppf d =
  Format.fprintf ppf "%a@\n" print d;
  dump_print ppf
63
64


65
66
67
68
69
let counter = State.ref "Patterns.counter" 0

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

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

76
let constr x = (x,IdSet.empty,Constr x)
77
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
78
79
80
81
82
  if not (IdSet.equal fv1 fv2) then (
    let x = match IdSet.pick (IdSet.diff fv1 fv2) with
      | Some x -> x
      | None -> match IdSet.pick (IdSet.diff fv2 fv1) with Some x -> x 
	  | None -> assert false
83
84
85
    in
    raise 
      (Error 
86
	 ("The capture variable " ^ (Id.value x) ^ 
87
88
	  " should appear on both side of this | pattern"))
  );
89
  (Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
90
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
91
92
93
  if not (IdSet.disjoint fv1 fv2) then (
    match IdSet.pick (IdSet.cap fv1 fv2) with
      | Some x -> 
94
95
	  raise 
	  (Error 
96
	     ("The capture variable " ^ (Id.value x) ^ 
97
	      " cannot appear on both side of this & pattern"))
98
      | None -> assert false
99
  );
100
  (Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2))
101
let times x y =
102
  (Types.times x.accept y.accept, IdSet.cup x.fv y.fv, Times (x,y))
103
let xml x y =
104
  (Types.xml x.accept y.accept, IdSet.cup x.fv y.fv, Xml (x,y))
105
let record l x = 
106
  (Types.record l x.accept, x.fv, Record (l,x))
107
108
let capture x = (Types.any, IdSet.singleton x, Capture x)
let constant x c = (Types.any, IdSet.singleton x, Constant (x,c))
109

110

111

112
113
114
115

(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
116
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
117
118
119
let times_res v1 v2 = Types.Positive.times v1 v2

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

let memo_filter = ref MemoFilter.empty

124
let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
125
(* TODO: avoid is_empty t when t is not changing (Cap) *)
126
127
128
129
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
130
      | Constr _ -> IdMap.empty
131
      | Cup ((a,_,_) as d1,d2) ->
132
	  IdMap.merge cup_res
133
134
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
135
      | Cap (d1,d2) ->
136
	  IdMap.merge cup_res (filter_descr t d1) (filter_descr t d2)
137
138
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
139
140
141
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
142
	  IdMap.singleton c (Types.Positive.ty t)
143
      | Constant (c, cst) ->
144
	  IdMap.singleton c (Types.Positive.ty (Types.constant cst))
145

146
147
148
149
and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
150
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
151
       in
152
       IdMap.merge cup_res accu term
153
154
155
156
157
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


158
and filter_node t p : Types.Positive.v id_map =
159
160
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
161
    let (_,fv,_) as d = descr p in
162
    let res = IdMap.map_from_slist (fun _ -> Types.Positive.forward ()) fv in
163
164
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
165
    IdMap.collide Types.Positive.define res r;
166
167
168
169
170
    r

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
171
  IdMap.get (IdMap.map Types.Positive.solve r)
172
173


174
(* Normal forms for patterns and compilation *)
175

176
177
let min (a:int) (b:int) = if a < b then a else b

178
179
180
181
182
module Normal : sig 
  type 'a sl = 'a SortedList.t
  type ('a,'b) sm = ('a,'b) SortedMap.t

  type source = 
183
184
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
185
  type result = source id_map
186
187
188
189

  type nnf = node sl * Types.descr
  type 'a nline = (result *  'a) list
  type record =
190
191
    | RecNolabel of result option * result option
    | RecLabel of Types.label * (nnf * nnf) nline 
192
193
194
195
196
197
198
  type t = {
    nfv    : fv;
    ncatchv: fv;
    na     : Types.descr;
    nbasic : Types.descr nline;
    nprod  : (nnf * nnf) nline;
    nxml   : (nnf * nnf) nline;
199
    nrecord: record;
200
201
202
  }

  val any_basic: Types.descr
203
204
  val first_label: descr -> Types.label
  val normal: Types.label option -> Types.descr -> node list -> t
205
end = 
206
struct
207
208
209
210
211
212
  let any_basic = 
    Types.Record.or_absent
      (Types.neg (List.fold_left Types.cup Types.empty
		    [Types.Product.any_xml;
		     Types.Product.any;
		     Types.Record.any]))
213
214


215
216
217
218
  type 'a sl = 'a SortedList.t
  type ('a,'b) sm = ('a,'b) SortedMap.t

  type source = 
219
220
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
221
  type result = source id_map
222
223
224

  type nnf = node sl * Types.descr   (* pl,t;   t <= \accept{pl} *)
  type 'a nline = (result *  'a) sl
225
  type record =
226
227
    | RecNolabel of result option * result option
    | RecLabel of Types.label * (nnf * nnf) nline
228
  type t = {
229
    nfv    : fv;
230
    ncatchv: fv;
231
    na     : Types.descr;
232
    nbasic : Types.descr nline;
233
234
    nprod  : (nnf * nnf) nline;
    nxml   : (nnf * nnf) nline;
235
    nrecord: record
236
  }
237

238

239
  let fus = IdMap.union_disj
240
  let slcup = SortedList.cup
241

242
243
244
245
246
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
      nbasic = []; nprod = []; nxml = []; 
      nrecord = (match lab with 
247
248
		   | Some l -> RecLabel (l,[]) 
		   | None -> RecNolabel (None,None))
249
    }
250
251
252
253
254
255


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
256
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
257
258
259
260
      na      = Types.cup nf1.na nf2.na;
      nbasic  = SortedList.cup nf1.nbasic nf2.nbasic;
      nprod   = SortedList.cup nf1.nprod nf2.nprod;
      nxml    = SortedList.cup nf1.nxml nf2.nxml;
261
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
262
263
264
265
		   | RecLabel (l1,r1), RecLabel (l2,r2) -> 
		       assert (l1 = l2); RecLabel (l1, slcup r1 r2)
		   | RecNolabel (x1,y1), RecNolabel (x2,y2) -> 
		       RecNolabel((if x1 = None then x2 else x1),
266
267
				(if y1 = None then y2 else y1))
		   | _ -> assert false)
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
    }

  let double_fold f l1 l2 =
    SortedList.from_list
      (List.fold_left 
	 (fun accu x1 ->
	    List.fold_left
	    (fun accu x2 ->
	       f accu x1 x2
	    )
	    accu l2
	 ) [] l1)
	 
  let ncap nf1 nf2 =
    let prod accu (res1,((pl1,t1),(ql1,s1))) (res2,((pl2,t2),(ql2,s2))) =
      let t = Types.cap t1 t2 in
      if Types.is_empty t then accu else
	let s = Types.cap s1 s2  in
	if Types.is_empty s then accu else
	  (fus res1 res2, ((slcup pl1 pl2,t),(slcup ql1 ql2,s))) :: accu
    in
    let basic accu (res1,t1) (res2,t2) =
      let t = Types.cap t1 t2 in
      if Types.is_empty t then accu else
	(fus res1 res2, t) :: accu
    in
294
    let do_record r1 r2 = match r1,r2 with
295
      | RecLabel (l1,r1), RecLabel (l2,r2) ->
296
	  assert (l1 = l2);
297
298
	  RecLabel(l1, double_fold prod r1 r2)
      | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
299
300
301
302
303
304
	  let x = match x1,x2 with 
	    | Some res1, Some res2 -> Some (fus res1 res2) 
	    | _ -> None
	  and y = match y1,y2 with
	    | Some res1, Some res2 -> Some (fus res1 res2)
	    | _ -> None in
305
	  RecNolabel (x,y)
306
      | _ -> assert false
307
    in
308
309
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
310
311
312
313
      na = Types.cap nf1.na nf2.na;
      nbasic = double_fold basic nf1.nbasic nf2.nbasic;
      nprod = double_fold prod nf1.nprod nf2.nprod;
      nxml = double_fold prod nf1.nxml nf2.nxml;
314
      nrecord = do_record nf1.nrecord nf2.nrecord;
315
316
    }

317
  let nnode p = [p], Types.descr p.accept
318
  let empty_res = IdMap.empty
319

320
  let ntimes lab acc p q = 
321
322
323
    let src_p = IdMap.constant SLeft p.fv
    and src_q = IdMap.constant SRight q.fv in
    let src = IdMap.merge_elem SRecompose src_p src_q in 
324
    { nempty lab with 
325
	nfv = IdSet.cup p.fv q.fv; 
326
	na = acc;
327
328
329
	nprod = [ (src, (nnode p, nnode q)) ];
    }

330
  let nxml lab acc p q = 
331
332
333
    let src_p = IdMap.constant SLeft p.fv
    and src_q = IdMap.constant SRight q.fv in
    let src = IdMap.merge_elem SRecompose src_p src_q in 
334
    { nempty lab with 
335
	nfv = IdSet.cup p.fv q.fv; 
336
337
	na = acc;
	nxml =  [ (src, (nnode p, nnode q)) ];
338
339
    }
    
340
341
342
343
344
345
346
347
348
349
350
351
352
  let nrecord lab acc l p =
    match lab with
      | None -> assert false
      | Some label ->
(*	  Printf.eprintf "[ l = %s; label = %s ]\n" 
	    (Types.LabelPool.value l)
	    (Types.LabelPool.value label); *)
	  assert (label <= l);
	  if l == label then
	    let src = IdMap.constant SLeft p.fv in
	    { nempty lab with
		nfv = p.fv;
		na = acc;
353
		nrecord = RecLabel(label, 
354
355
356
357
358
359
360
361
362
				 [ (src,(nnode p, ([], Types.any))) ])}
	  else
	    let src = IdMap.constant SRight p.fv in
	    let p' = make p.fv in  (* optimize this ... *)
	      (* cache the results to avoid looping ... *)
	    define p' (record l p);
	    { nempty lab with
		nfv = p.fv;
		na = acc;
363
		nrecord = RecLabel(label,
364
365
366
367
368
369
370
371
372
373
374
				 [ (src,(([], Types.Record.any_or_absent), 
					 nnode p')) ])}
	  

  let nconstr lab t =
    let aux = List.map (fun (t1,t2) -> empty_res, (([],t1),([],t2))) in
    let record = 
      match lab with
	| None ->
	    (* Should check that r has only empty_cases *)
	    let (x,y) = Types.Record.empty_cases t in
375
	    RecNolabel ((if x then Some empty_res else None), 
376
377
		      (if y then Some empty_res else None))
	| Some l ->
378
	    RecLabel (l,aux (Types.Record.split_normal t l))
379
380
    in	      
    { nempty lab with
381
	na = t;
382
	nbasic = [ empty_res, Types.cap t any_basic ];
383
384
385
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
386
387
    }

388
  let nconstant lab x c = 
389
390
391
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
392
393
394
395
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
396
      nrecord = match lab with
397
	| None -> RecNolabel (Some l, Some l)
398
	| Some lab -> 
399
	    RecLabel (lab, [ (l,(([], Types.Record.any_or_absent),
400
			       ([], Types.any))) ])
401
402
    }

403
  let ncapture lab x = 
404
405
406
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
407
408
409
410
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
411
      nrecord = match lab with
412
	| None -> RecNolabel (Some l, Some l)
413
	| Some lab -> 
414
	    RecLabel (lab, [ (l,(([], Types.Record.any_or_absent),([], Types.any))) ])
415
416
    }

417
  let rec nnormal lab (acc,fv,d) =
418
    if Types.is_empty acc 
419
    then nempty lab
420
    else match d with
421
422
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
423
      | Cup ((acc1,_,_) as p,q) -> 
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
	  ncup (nnormal lab p) (ncap (nnormal lab q) 
				  (nconstr lab (Types.neg acc1)))
      | Times (p,q) -> ntimes lab acc p q
      | Xml (p,q) -> nxml lab acc p q
      | Capture x -> ncapture lab x
      | Constant (x,c) -> nconstant lab x c
      | Record (l,p) -> nrecord lab acc l p

(*TODO: when an operand of Cap has its first_label > lab,
  directly shift it*)

  let rec first_label (acc,fv,d) =
    if Types.is_empty acc 
    then Types.LabelPool.dummy_max
    else match d with
      | Constr t -> Types.Record.first_label t
      | Cap (p,q) -> min (first_label p) (first_label q)
      | Cup ((acc1,_,_) as p,q) -> min (first_label p) (first_label q)
	    (* should "first_label_type acc1" ? *)
      | Record (l,p) -> l
      | _ -> Types.LabelPool.dummy_max

446
447
448
449
   
  let remove_catchv n =
    let ncv = n.ncatchv in
    let nlines l = 
450
      let l = List.map (fun (res,x) -> (IdMap.diff res ncv,x)) l in
451
452
(*       let l = SortedList.from_list l in (* Can get rid of it ? *) *)
      l in
453
    { nfv     = IdSet.diff n.nfv ncv;
454
455
456
457
458
      ncatchv = n.ncatchv;
      na      = n.na;
      nbasic  = nlines n.nbasic;
      nprod   = nlines n.nprod;
      nxml    = nlines n.nxml;
459
      nrecord = (match n.nrecord with
460
		   | RecNolabel (x,y) ->
461
462
463
464
465
466
		       let x = match x with 
			 | Some res -> Some (IdMap.diff res ncv) 
			 | None -> None in
		       let y = match y with 
			 | Some res -> Some (IdMap.diff res ncv) 
			 | None -> None in
467
468
		       RecNolabel (x,y)
		   | RecLabel (lab,l) -> RecLabel (lab, nlines l))
469
470
    }

471
  let normal l t pl =
472
    remove_catchv
473
474
475
476
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
477
end
478
479


480
481
module Compile = 
struct
482
  type actions =
483
484
    | AIgnore of result
    | AKind of actions_kind
485
  and actions_kind = {
486
487
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
488
    xml: result dispatch dispatch;
489
490
491
    record: record option;
  }
  and record = 
492
493
    | RecLabel of Types.label * result dispatch dispatch
    | RecNolabel of result option * result option
494
      
495
  and 'a dispatch =
496
497
498
499
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
500
501

  and result = int * source array
502
  and source = 
503
504
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
505
506
507
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
508
      (int * int id_map) list
509
510

  and interface =
511
512
    [ `Result of int
    | `Switch of interface * interface
513
514
515
516
517
518
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
519
    label : Types.label option;
520
521
    interface : interface;
    codes : return_code array;
522
523
    mutable actions : actions option;
    mutable printed : bool
524
  }
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539

  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

540
  let combine_kind basic prod xml record =
541
542
543
544
545
546
547
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
548
549
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
550
	| _ -> raise Exit in
551
      let rs = match xml with
552
553
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
554
	| _ -> raise Exit in
555
556
      let rs = match record with
	| None -> rs
557
558
	| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
	| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
559
560
	| _ -> raise Exit in
      match rs with
561
562
563
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
564
565
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
566
567
	| _ -> raise Exit
    )
568
    with Exit -> AKind { basic = basic; prod = prod; xml = xml; record = record }
569

570
  let combine (disp,act) =
571
    if Array.length act = 0 then Impossible
572
573
574
    else
      if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes) 
	 && (array_for_all ( (=) act.(0) ) act) then
575
	   Ignore act.(0)
576
      else
577
	Dispatch (disp, act)
578
579
580


  let detect_right_tail_call = function
581
    | Dispatch (disp,branches) 
582
583
584
585
586
587
	when
	  array_for_all_i
	    (fun i (code,ret) ->
	       (i = code) && 
	       (array_for_all_i 
		  (fun pos -> 
588
		     function Right j when pos = j -> true | _ -> false)
589
590
591
		  ret
	       )
	    ) branches
592
	  -> TailCall disp
593
594
595
    | x -> x

  let detect_left_tail_call = function
596
    | Dispatch (disp,branches)
597
598
599
600
	when
	  array_for_all_i
	    (fun i -> 
	       function 
601
		 | Ignore (code,ret) ->
602
603
604
		     (i = code) &&
		     (array_for_all_i 
			(fun pos -> 
605
			   function Left j when pos = j -> true | _ -> false)
606
607
608
609
610
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
611
	 TailCall disp
612
613
    | x -> x
   
614
615
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
616
		 
617
618
  module DispMap = Map.Make(
    struct
619
      type t = Types.descr * Normal.t array
620
621
622
      let compare = compare
    end
  )
623
    
624
  let dispatchers = ref DispMap.empty
625
		      
626
  let dispatcher t pl lab : dispatcher =
627
628
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
629
      let nb = ref 0 in
630
631
      let codes = ref [] in
      let rec aux t arity i accu = 
632
633
	if Types.is_empty t then `None
	else
634
	  if i = Array.length pl 
635
	  then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
636
637
	  else
	    let p = pl.(i) in
638
	    let tp = p.Normal.na in
639
640
641
642
	    assert(IdSet.disjoint p.Normal.nfv p.Normal.ncatchv);
	    let v = p.Normal.nfv in
(*	    let v = IdSet.diff p.Normal.nfv p.Normal.ncatchv in*)

643
(*	    let tp = Types.normalize tp in *)
644
	    let accu' = (i,IdMap.num arity v) :: accu in
645
	    `Switch 
646
	      (
647
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
648
	       aux (Types.diff t tp) arity (i+1) accu
649
650
	      )
      in
651
      let iface = aux t 0 0 [] in
652
653
      let res = { id = !cur_id; 
		  t = t;
654
		  label = lab;
655
		  pl = pl;
656
		  interface = iface;
657
		  codes = Array.of_list (List.rev !codes);
658
		  actions = None; printed = false } in
659
660
661
662
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
663
664
  let find_code d a =
    let rec aux i = function
665
666
667
668
      | `Result code -> code
      | `None -> assert false
      | `Switch (yes,_) when a.(i) <> None -> aux (i + 1) yes
      | `Switch (_,no) -> aux (i + 1) no
669
670
671
672
    in
    aux 0 d.interface

  let create_result pl =
673
674
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
675
676
677
678
679
680

  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)
    
681
  let conv_source_basic s = match s with
682
683
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
684
685
    | _ -> assert false

686
  let assoc v l =
687
    try IdMap.assoc v l with Not_found -> -1
688

689
  let conv_source_prod left right v s = match s with
690
691
692
693
694
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
    | Normal.SLeft -> Left (assoc v left)
    | Normal.SRight -> Right (assoc v right)
    | Normal.SRecompose -> Recompose (assoc v left, assoc v right)
695
696

  let dispatch_basic disp : (Types.descr * result) list =
697
(* TODO: try other algo, using disp.codes .... *)
698
699
700
701
702
703
704
705
    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
706
    let accu = ref [] in
707
    let rec aux (success : (int * Normal.result) list) t l = 
708
709
710
      if Types.non_empty t 
      then match l with
	| [] ->
711
712
713
714
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
715
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
716
717
718
719
	    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
720
    in
721
    aux [] t tests;
722
723
724
    !accu


725
  let get_tests pl f t d post =
726
727
728
729
    let accu = ref [] in
    let unselect = Array.create (Array.length pl) [] in
    let aux i x = 
      let yes, no = f x in
730
      List.iter (fun ( (pl,ty), info) -> accu := (ty,pl,i,info) :: !accu
731
732
733
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;
734

735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
    let lab =
      List.fold_left 
	(fun l (ty,pl,_,_) ->
	   List.fold_left
	     (fun l p -> min l (Normal.first_label (descr p)))
	     (min l (Types.Record.first_label ty))
	     pl
	) Types.LabelPool.dummy_max !accu in
    let lab = if lab= Types.LabelPool.dummy_max then None else Some lab in

    let accu = 
      List.map (fun (ty,pl,i,info) -> 
		  let p = Normal.normal lab ty pl in
		  (p,[i, p.Normal.ncatchv, info])) 
	!accu in
    let sorted = Array.of_list (SortedMap.from_list SortedList.cup accu) in
751
    let infos = Array.map snd sorted in
752
    let disp = dispatcher t (Array.map fst sorted) lab in
753
    let result (t,_,m) =
754
      let selected = Array.create (Array.length pl) [] in
755
      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
756
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
757
758
      d t selected unselect
    in
759
    let res = Array.map result disp.codes in
760
761
    post (disp,res)

762

763
764
765
766
  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
767
	   let p' = ([p],t) in
768
769
	   let t' = Types.diff t (Types.descr (accept p)) in
	   (t', (p',e) :: brs)
770
	) (t,[]) brs in
771
	
772
773
774
775
776
777
778
779
    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 
780
	   | [(res,catchv,e)] -> assert (!r = None); 
781
782
	       let catchv = IdMap.constant (-1) catchv in
	       r := Some (IdMap.union_disj catchv res,e)
783
784
785
786
787
788
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)
789
790


791
792
793
794
795
796
797
  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
798
799
    dispatch_prod0 disp t pl
  and dispatch_prod0 disp t pl =
800
801
802
803
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
804
      (fun x -> detect_left_tail_call (combine x))
805
806
  and dispatch_prod1 disp t t1 pl _ =
    get_tests pl
807
      (fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] ) 
808
809
      (Types.Product.pi2_restricted t1 t)
      (dispatch_prod2 disp)
810
      (fun x -> detect_right_tail_call (combine x))
811
  and dispatch_prod2 disp t2 pl _ =
812
    let aux_final (ret2, ncatchv, (ret1, res)) =  
813
      IdMap.mapi_to_list (conv_source_prod ret1 ret2) res in
814
    return disp pl aux_final
815
816
817


  let rec dispatch_record disp : record option =
818
819
820
821
822
823
824
825
826
    let t = disp.t in
    if not (Types.Record.has_record t) then None 
    else
      match disp.label with
	| None -> 
	    let (some,none) = Types.Record.empty_cases t in
	    let some =
	      if some then 
		let pl = Array.map (fun p -> match p.Normal.nrecord with
827
828
				      | Normal.RecNolabel (Some x,_) -> [x]
				      | Normal.RecNolabel (None,_) -> []
829
830
831
832
833
834
835
				      | _ -> assert false) disp.pl in
		Some (return disp pl (IdMap.map_to_list conv_source_basic))
	      else None
	    in
	    let none =
	      if none then 
		let pl = Array.map (fun p -> match p.Normal.nrecord with
836
837
				      | Normal.RecNolabel (_,Some x) -> [x]
				      | Normal.RecNolabel (_,None) -> []
838
839
840
841
				      | _ -> assert false) disp.pl in
		Some (return disp pl (IdMap.map_to_list conv_source_basic))
	      else None
	    in	      
842
	    Some (RecNolabel (some,none))
843
844
845
	| Some lab ->
	    let t = Types.Record.split t lab in
	    let pl = Array.map (fun p -> match p.Normal.nrecord with
846
				  | Normal.RecLabel (_,l) -> l
847
				  | _ -> assert false) disp.pl in
848
	    Some (RecLabel (lab,dispatch_prod0 disp t pl))
849
850
(* soucis avec les ncatchv ?? *)

851
      
852
853
854
855
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
856
857
858
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
859
		    (dispatch_prod ~kind:`XML disp)
860
861
		    (dispatch_record disp)
	  in
862
863
864
865
	  disp.actions <- Some a;
	  a

  let to_print = ref []
866
867
868

  module DSET = Set.Make (struct type t = int let compare (x:t) (y:t) = x - y end)
  let printed = ref DSET.empty
869
870

  let queue d =
871
872
    if not d.printed then (
      d.printed <- true;
873
874
875
      to_print := d :: !to_print
    )

876
  let rec print_source ppf = function
877
878
879
880
881
882
883
    | 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"
    | Left i -> Format.fprintf ppf "l%i" i
    | Right j -> Format.fprintf ppf "r%i" j
    | Recompose (i,j) -> 
884
	Format.fprintf ppf "(%a,%a)" 
885
886
	  print_source (Left i)
	  print_source (Right j)
887
888
889
890
891
892
893
894
895
896
897
898
899

  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

900
901
902
903
  let print_ret_opt ppf = function
    | None -> Format.fprintf ppf "*"
    | Some r -> print_ret ppf r

904
  let print_kind ppf actions =
905
    let print_lhs ppf (code,prefix,d) =
906
      let arity = match d.codes.(code) with (_,a,_) -> a in