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

4
5
exception IllFormedCup of fv * fv
exception IllFormedCap of fv * fv
6

7
(* Syntactic algebra *)
8

9
type d =
10
  | Constr of Types.node
11
  | Cup of descr * descr
12
  | Cap of descr * descr
13
  | Times of node * node
14
15
16
  | Record of Types.label * node
  | Capture of capture
  | Constant of capture * Types.const
17
18
and node = {
  id : int;
19
20
  mutable descr : descr option;
  accept : Types.node;
21
  fv : fv
22
} and descr = Types.descr * fv * d
23

24
25
26
27
28
let make =
  let counter = ref 0 in
  fun fv ->
    incr counter;
    { id = !counter; descr = None; accept = Types.make (); fv = fv }
29
30

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

35
let constr x = (Types.descr x,[],Constr x)
36
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
37
38
  if fv1 <> fv2 then raise (IllFormedCup (fv1,fv2));
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
39
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
40
41
  if not (SortedList.disjoint fv1 fv2) then raise (IllFormedCap (fv1,fv2));
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2))
42
let times x y =
43
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
44
let record l x = 
45
46
47
  (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))
48

49
50
51
52
53

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
54

55
56
57
58

(* Static semantics *)

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

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

let memo_filter = ref MemoFilter.empty

67
let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
68
69
70
71
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
72
      | Constr _ -> []
73
      | Cup ((a,_,_) as d1,d2) ->
74
	  SortedMap.union cup_res
75
76
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
77
      | Cap (d1,d2) ->
78
79
80
81
82
83
84
85
86
87
88
89
90
	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
      | Times (p1,p2) ->
	  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 t)
91
92
93
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
94
	  [(c, Types.Positive.ty t)]
95
      | Constant (c, cst) ->
96
97
98
	  [(c, Types.Positive.ty (Types.constant cst))]

and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
99
100
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
101
102
    let (_,fv,_) as d = descr p in
    let res = List.map (fun v -> (v,Types.Positive.forward ())) fv in
103
104
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
105
    List.iter2 (fun (_,r) (_,v) -> Types.Positive.define v r) r res;
106
107
108
109
110
    r

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

113

114

115
(* Normal forms for patterns and compilation *)
116

117
118
119
120
121
122
123
124
125
126
127
128
129
module NF = 
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

130
  type 'a line = (result * 'a, Types.descr) sm
131
132
133
  type nf = {
    v     : fv;
    a     : Types.descr;
134
135
136
137
138
139
140
141
142
143
144
145
    basic : unit line;
    prod  : (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 normal = {
146
147
    nfv    : fv;
    na     : Types.descr;
148
149
150
    nbasic : Types.descr nline;
    nprod  : (nf * nf) nline;
    nrecord: record nline
151
  }
152

153
154
  let empty = { v = []; a = Types.empty; basic = []; prod = []; record = [] }
  let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)
155

156

157
  let restrict t nf =
158
159
160
161
162
163
    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
164
165
    {  v = nf.v;
       a = Types.cap t nf.a;
166
167
168
       basic = filter nf.basic;
       prod = filter nf.prod;
       record = filter nf.record;
169
    }
170

171
172
  let fus = SortedMap.union_disj
  let slcup = SortedList.cup
173

174
  let cap nf1 nf2 =
175
176
177
178
179
180
181
182
183
184
185
186
187
188
    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 () () = ()
189
    and merge_prod (p1,q1) (p2,q2) = slcup p1 p2, slcup q1 q2
190
    and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
191
192
    { v = SortedList.cup nf1.v nf2.v;
      a = Types.cap nf1.a nf2.a;
193
194
195
      basic = merge merge_basic nf1.basic nf2.basic;
      prod = merge merge_prod nf1.prod nf2.prod;
      record = merge merge_record nf1.record nf2.record;
196
    }
197

198

199
200
201
		  
  let cup acc1 nf1 nf2 =
    let nf2 = restrict (Types.neg acc1) nf2 in
202
    { v = nf1.v; (* = nf2.v *)
203
204
      a = Types.cup nf1.a nf2.a;
      basic = SortedMap.union Types.cup nf1.basic nf2.basic;
205
206
      prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
      record = SortedMap.union Types.cup nf1.record nf2.record;
207
    }
208

209
210
211
212
213
214
215
  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;
216
	prod = [ (src, ([p], [q])), acc ] }
217
218
219
220
221
222

  let record acc l p =
    let src = List.map (fun v -> (v, `Field l)) p.fv in
    { empty with
	v = p.fv;
	a = acc;
223
	record = [ (src, [l,[p]]), acc ] }
224
225
226
227

  let any =
    { v = [];
      a = Types.any;
228
229
230
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
      record = [ ([],[]), Types.Record.any ];
231
    }
232

233
234
235
236
  let capture x =
    let l = [x,`Catch] in
    { v = [x];
      a = Types.any;
237
238
239
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      record = [ (l,[]), Types.Record.any ];
240
    }
241

242
243
244
245
  let constant x c =
    let l = [x,`Const c] in
    { v = [x];
      a = Types.any;
246
247
248
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      record = [ (l,[]), Types.Record.any ];
249
    }
250

251
252
253
  let constr t =
    { v = [];
      a = t;
254
255
256
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
      record = [ ([],[]), Types.cap t Types.Record.any ];
257
    }
258

259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
(* 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
      | 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 rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)

276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
  let normal nf =
    let basic =
      List.map (fun ((res,()),acc) -> (res,acc)) 

    and prod =
      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
	List.fold_left aux accu (Types.Product.normal acc) in
      List.fold_left line []

    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 pr = 
		List.map (fun (t,x) -> (constr t, aux x fields)) pr in
	      `Label (l1, pr, aux ab fields)
      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
315
316
317
    { nfv     = nf.v;
      na      = nf.a;
      nbasic  = basic nf.basic;
318
319
320
321
      nprod   = prod nf.prod;
      nrecord = record nf.record;
    }

322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
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
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760

  module Disp = struct

    type actions = {
      basic: (Types.descr * result) list;
      prod: result dispatch dispatch;
      record: record option;
    }
    and record = 
	[ `Label of Types.label * record dispatch * record option
	| `Result of result ]

    and 'a dispatch = dispatcher * 'a array
    and result = int * source list
    and source = 
	[ `Catch | `Const of Types.const 
	| `Left of int | `Right of int | `Recompose of int * int
	| `Field of Types.label * int
	]
      
    and dispatcher = {
      id : int;
      t  : Types.descr;
      pl : normal array;
      interface : (Types.descr * int * (capture, int) sm option array) array;
      mutable actions : actions option
    }

    let cur_id = ref 0

  module DispMap = Map.Make(
    struct
      type t = Types.descr * normal array
      let compare = compare
    end
  )

  let dispatchers = ref DispMap.empty

  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
      let res = ref [] in
      let rec aux t bindings arity i = 
	if Types.non_empty t 
	then 
	  if i = Array.length pl 
	  then res := (t, arity, Array.of_list (List.rev bindings)) :: !res
	  else
	    let p = pl.(i) in
	    aux (Types.cap t p.na) (Some (num arity p.nfv) :: bindings)
	      (arity + (List.length p.nfv)) (i+1);
	    aux (Types.diff t p.na) (None :: bindings) arity (i+1)
      in
      aux t [] 0 0;
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
		  interface = Array.of_list !res; 
		  actions = None } in
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
  let flatten pl =
    let accu = ref [] and idx = ref [] in
    let aux i x = accu := x :: !accu; idx := i :: !idx  in
    Array.iteri (fun i -> List.iter (aux i)) pl;
    Array.of_list !idx,
    Array.of_list !accu

  let collect f pl =
    let accu = ref [] in
    let aux (res,x) = try accu := (f x) :: !accu with Exit -> () in
    Array.iter (List.iter aux) pl;
    SortedList.from_list (!accu)


  let rec find_uniq f = function
    | [] -> None
    | (res,x) :: rem -> if (f x) then Some res else find_uniq f rem

  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 : dispatcher) a =
    let rec aux i =
      if i = Array.length d.interface 
      then raise Not_found
      else 
	match d.interface.(i) with
	  | (_,_,m) when compare_masks m a  -> i
	  | _ -> aux (i + 1) in
    aux 0

  let conv_source_basic = function
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

  let create_result f pl =
    let res = ref [] in
    Array.iter
      (function 
	 | Some b -> List.iter (fun x -> res := f x :: !res) b
	 | None -> ()
      ) pl;
    List.rev !res
    
  let filter f = Array.map (find_uniq f)

  let dispatch_basic d : (Types.descr * result) list =
    let pl = Array.map (fun p -> p.nbasic) d.pl in
    let tests = collect (fun x -> x) pl in
    let t = Types.cap any_basic d.t in
    let accu = ref [] in
    let rec aux t l = 
      if Types.non_empty t 
      then match l with
	| [] ->
	    let pl = filter (Types.subtype t) pl in
	    let code = find_code d pl in
	    let res = create_result (fun (v,s) -> conv_source_basic s) pl in
	    accu := (t, (code,res)) :: !accu
	| ty :: rem -> aux (Types.cap t ty) rem; aux (Types.diff t ty) rem
    in
    aux t tests;
    !accu


  let get_tests pl f t d =
    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
		   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,arity,m) =
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
      Array.iteri 
	(fun j -> function Some r -> List.iter (add r) infos.(j) | None -> ())
	m;
      d t selected unselect
    in
    let res = Array.map result disp.interface in
    (disp,res)


  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
    | `Left -> 
(*
Printf.eprintf "Left %s\n" v;
List.iter (fun (v,i) -> Printf.eprintf "  LEFT(%s => %i)\n" v i) left;
List.iter (fun (v,i) -> Printf.eprintf "  RIGHT(%s => %i)\n" v i) right;
flush stderr;
*)
	`Left (List.assoc v left)
    | `Right -> `Right (List.assoc v right)
    | `Recompose -> `Recompose (List.assoc v left, List.assoc v right)
    | _ -> assert false

  let rec dispatch_prod disp : (result dispatch dispatch) =
(*
    Printf.eprintf "dispatch_prod %i: " disp.id;
    Array.iteri (fun i p ->
		   Printf.eprintf "(%i:" i;
		   List.iter (fun v -> Printf.eprintf "%s" v) p.nfv;
		   Printf.eprintf ")";
		) disp.pl;
    Printf.eprintf "\n";
    flush stderr;
*)
    let pl = Array.map (fun p -> p.nprod) disp.pl in
    let t = Types.Product.get disp.t in
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
  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)
  and dispatch_prod2 disp t t2 pl _ =
    let aux_final = function
      | [] -> None
      | [(ret2, (ret1, res))] -> 
	  Some (List.map (conv_source_prod ret1 ret2) res)
      | _ -> assert false in
    let final = Array.map aux_final pl in
    let code = find_code disp final in
    let ret = create_result (fun s -> s) final in
    (code,ret)


  let dummy_label = Types.label ""

  let collect_first_label pl =
    let f = ref true and m = ref dummy_label in
    let aux = function
      | (res, _, `Label (l, _, _)) ->
	  if (!f) then (f := false; m := l) else if (l < !m) then m:= l;
      | _ -> () in
    Array.iter (List.iter aux) pl;
    if !f 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 conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
    | `Field l -> `Field (l, List.assoc v (List.assoc l catch))
    | _ -> assert false

  let rec dispatch_record disp : record option =
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.nrecord in
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
    dispatch_record_opt disp t pl0
  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 =
    match collect_first_label pl with
      | None -> 
	  let aux_final = function
	    | [(res, catch, `Success)] -> 
		Some (List.map (conv_source_record catch) res)
	    | [] -> None
	    | _ -> assert false in
	  let final = Array.map aux_final pl in
	  let code = find_code disp final in
	  let ret = create_result (fun s -> s) final in
	  `Result (code,ret)
      | Some l ->
	  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)
	  in
	  let absent = 
	    let pl = label_not_found l pl in
	    let t = Types.Record.restrict_label_absent t l in
	    dispatch_record_opt disp t pl
	  in
	  `Label (l, present, absent)
  and dispatch_record_field l disp t tfield pl others =
    let t = Types.Record.restrict_field t l tfield in
    let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
    dispatch_record_label disp t pl
    

  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
	  let a = {
	    basic = dispatch_basic disp;
	    prod  = dispatch_prod disp;
	    record = 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 print_actions ppf actions =
    let print_source ppf = function
      | `Catch  -> Format.fprintf ppf "v"
      | `Const c -> Types.Print.print_const ppf c
      | `Left i -> Format.fprintf ppf "l%i" i
      | `Right j -> Format.fprintf ppf "r%i" j
      | `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
      | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
    in
    let rec print_result ppf = function
      | [] -> ()
      | [s] -> print_source ppf s
      | s::rem -> Format.fprintf ppf "%a," print_source s; print_result ppf rem
    in
    let print_ret ppf (code,ret) = 
      Format.fprintf ppf "$%i(%a)" code print_result ret in
    let print_lhs ppf (code,prefix,d) =
      let arity = match d.interface.(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 (d,rem) =
      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;
   	)
	rem
    in
    let print_prod (d,rem) =
      if Array.length rem > 0 then (
	queue d;
	Format.fprintf ppf " | (v1,v2) -> @\n";
	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;
   	  )
	  rem
      )
    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
      | `Label (l, (d,present), absent) ->
	  let l = Types.label_name l in
	  queue d;
	  Format.fprintf ppf " check label %s:@\n" l;
	  Format.fprintf ppf "  Present => 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
	    ) present;
	  match absent with
	    | Some r ->
		Format.fprintf ppf "  Absent => @[%a@]@\n"
		   print_record r
	    | None -> ()
    in
    
    List.iter print_basic actions.basic;
    print_prod actions.prod;
    print_record_opt ppf actions.record

  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 d.t;
(*
	  Array.iteri
	    (fun code (t, arity, m) ->
	       Format.fprintf ppf "  $%i(arity=%i) accepts [%a]" 
	         code arity
	         Types.Print.print_descr t;
	       Array.iter
	       (function 
		  | None -> Format.fprintf ppf " None"
		  | Some b -> 
		      Format.fprintf ppf " Some(";
		      List.iter 
			(fun (v,i) ->  Format.fprintf ppf "%s=>%i;" v i)
			b;
		      Format.fprintf ppf ")"
	       ) m; 
	       Format.fprintf ppf "@\n";
	    )
	    d.interface;
*)
	  Format.fprintf ppf "disp_%i = function@\n" d.id;
	  print_actions ppf (actions d);
	  print_dispatchers ppf

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

  end


(***************************************************************


761
762
763
  let collect f pp =
    let aux accu (res,x) = (f x) :: accu in
    SortedList.from_list (List.fold_left (List.fold_left aux) [] pp)
764

765
766
767
768
769
  let rec map_map f = function 
    | [] -> [] 
    | x::l -> 
	try let y = f x in y::(map_map f l)
	with Not_found -> map_map f l
770

771
772
773
774
  let get_option = function [x] -> Some x | [] -> None | _ -> assert false
  let extract_unique f l = get_option (map_map f l)
(* Could optimize to extract directly the first (and single) *)

775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
  module Dispatch = struct
    type t = {
      id    : int;
      fv    : fv list;
      masks : (mask * (int * int * (capture, int) sm option array)) list;
      basic : (Types.descr * (result option list)) list;
      prod  : prod;
      record: record option;

      mutable basic' : (Types.descr * result') list option;
      mutable prod' : result' disp' disp' option
    }
    and prod = prod_result disp disp
    and prod_result = (result * (int * int)) option list

    and record = 
	[ `Label of Types.label * record disp * record option
	| `Result of record_result ]
    and record_result = (result * (Types.label * int) list) option list

    and mask = bool list
    and 'a disp = (Types.descr * nf SortedList.t) * (mask * 'a) list
    and 'a disp' = t * (int * 'a) list

    and result' = int * source' list
    and source' = 
      [ `Catch | `Const of Types.const 
      | `Left of int | `Right of int | `Recompose of int * int
      | `Field of Types.label * int
      ]
  end



809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
(* Basic (and arrow) types *)

  let filter_basic ty =
    let aux (k,t) = if Types.subtype ty t then k else raise Not_found in
    List.map (extract_unique aux)
   
  let dispatch_basic t pl =
    let rec aux pl accu t l = 
      if Types.is_empty t then accu 
      else match l with
	| [] ->
	    let pl = filter_basic t pl in
	    (t, pl) :: accu
	| ty :: rem ->
	    let accu = aux pl accu (Types.cap t ty) rem in
	    let accu = aux pl accu (Types.diff t ty) rem in
	    accu
    in
827
    let pl = List.map (fun p -> p.nbasic) pl in
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
    let tests = collect (fun x -> x) pl in
    let t = Types.cap any_basic t in
    aux pl [] t tests

(* Product types *)

  let filter_prod1 success =
    let aux (res,(p,q)) = (res,(List.assoc p success,q)) in
    List.map (map_map aux)

  let filter_prod2 success =
    let aux (res,(i,q)) = (res,(i,List.assoc q success)) in
    List.map (extract_unique aux)

  let rec dispatch_prod t pl =
843
    let pl = List.map (fun p -> p.nprod) pl in
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
    let tests = collect (fun (p,_) -> p) pl in
    let t = Types.Product.get t in
    let disp = aux_prod1 t pl [] [] [] 0 tests in
    let pi1 = Types.Product.pi1 t in
    ((pi1,tests),disp)

  and aux_prod2 t pl accu mask success j tests = 
    if Types.is_empty t then accu 
    else match tests with
      | [] ->
	  let pl = filter_prod2 success pl in
	  (List.rev mask, pl) :: accu
      | p :: rem -> 
	  let accu =
	    let t = Types.cap t p.a in
	    aux_prod2 t pl accu (true::mask) ((p,j)::success) (j+1) rem in
	  let accu =
	    let t = Types.diff t p.a in
	    aux_prod2 t pl accu (false::mask) success (j+1) rem in
	  accu
864

865
866
867
868
869
870
871
872
873
  and aux_prod1 t pl accu mask success i tests =
    if t = [] then accu 
    else match tests with
      | [] ->
	  let pl = filter_prod1 success pl in
	  let t = Types.Product.pi2 t in
	  let tests = collect (fun (_,q)-> q) pl in
	  let disp = aux_prod2 t pl [] [] [] 0 tests in
	  let mask = List.rev mask in
874
	  (mask, ((t,tests), disp)) :: accu
875
876
877
878
879
880
881
882
883
884
      | p :: rem ->
	  let accu = 
	    let t = Types.Product.restrict_1 t p.a in
	    aux_prod1 t pl accu (true::mask) ((p,i)::success) (i+1) rem in
	  let accu =
	    let t = Types.Product.restrict_1 t (Types.neg p.a) in
	    aux_prod1 t pl accu (false::mask) success (i+1) rem in
	  accu

(* Record types *)
885

886

887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
  let map_record f = 
    let rec aux = function
      | [] -> []
      | h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in
    List.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_disp l success =
    map_record
      (function
	 | (res, catch, `Dispatch disp) ->
	     let aux (p,rem) = (List.assoc p success, rem) in
	     (match extract_unique aux disp with
		| None -> (res, catch, `Fail)
		| Some (i,rem) -> (res, (l, i)::catch, rem))
	 | x -> x)

  let label_not_found l = 
    map_record 
      (function
	 | (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
	 | x -> x)


  let dummy_label = Types.label ""

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

  let collect_record pp =
    let aux accu = function
      | (res,catch,`Dispatch disp) ->  
	  List.fold_left (fun accu (p,_) -> p :: accu) accu disp
      | _ -> accu in
    SortedList.from_list (List.fold_left (List.fold_left aux) [] pp)

  let final_record =
    let aux = function
      | [(res, catch, `Success)] -> Some (res, catch)
      | [] -> None
      | _ -> assert false in
    List.map aux

(* combiner les restrict field, ... *)
  let rec dispatch_record t pl =
944
945
946
    let pl = List.map 
	       (fun p -> List.map (fun (res,r) -> (res,[],r)) p.nrecord
	       ) pl in
947
    let t = Types.Record.get t in
948
    if Types.Record.is_empty t then None else Some (aux_record1 t pl)
949

950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
  and aux_record1 t pl =
    match collect_first_label pl with
      | None -> `Result (final_record pl)
      | Some l ->
	  let (disp,pr) = 
	    let pl = label_found l pl in
	    let tests = collect_record pl in
	    let t = Types.Record.restrict_label_present t l in
	    let disp = aux_record2 t pl l [] [] [] 0 tests in
	    ((Types.Record.project_field t l, tests),disp)
	  in
	  let ab = 
	    let pl = label_not_found l pl in
	    let t = Types.Record.restrict_label_absent t l in
	    if Types.Record.is_empty t then None 
	    else Some (aux_record1 t pl)
	  in
967
	  `Label (l, (disp, pr), ab)
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
	    
  and aux_record2 t pl l accu mask success i tests =
    if Types.Record.is_empty t then accu
    else match tests with
      | [] ->
	  let pl = label_disp l success pl in
	  let disp = aux_record1 t pl in
	  (List.rev mask, disp) :: accu
      | p :: rem ->
	  let accu =
	    let t = Types.Record.restrict_field t l p.a in
	    aux_record2 t pl l accu (true::mask) ((p,i)::success) (i+1) rem in
	  let accu =
	    let t = Types.Record.restrict_field t l (Types.neg p.a) in
	    aux_record2 t pl l accu (false::mask) success (i+1) rem in
983
	  accu
984

985
986
  let mask l = List.map (function None -> false | Some _ -> true) l

987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
  module D = Map.Make(
    struct
      type t = Types.descr * normal list
      let compare = compare
    end
  )

  let dispatchers = ref D.empty
  let id = ref 0

  let rec dispatch (t : Types.descr) (pl : normal list) =
    try D.find (t,pl) !dispatchers
    with Not_found ->
      let basic = dispatch_basic t pl
      and prod = dispatch_prod t pl 
      and record = dispatch_record t pl in

      let alloc mask =
	let arity = ref 0 in
	let rec aux pl mask = 
	  match (pl,mask) with
	  | ([],[]) -> []
	  | (p :: pl, true :: mask) ->
	      let l = 
		   List.map (fun v -> incr arity; (v,!arity-1)) p.nfv in
	      Some l :: aux pl mask
	  | (_ :: pl, false :: mask) -> None :: aux pl mask
	  | _ -> assert false
	in
	let r = aux pl mask in
	!arity, Array.of_list r
      in	      

      let map_disp f ((t,pl),l) =
	let pl = List.map (fun p -> normal (restrict t p)) pl in
	let d = dispatch t pl in
	let r =  List.map 
		   (fun (m,r) -> 
		      let (code,_,res) = 
			try List.assoc m d.Dispatch.masks
			with Not_found -> assert false
		      in
		      (code, f res r)) l 
	in
	(d, r)
      in

      let map_basic masks =
	let source : source -> Dispatch.source' = function
	  | `Catch -> `Catch
	  | `Const c -> `Const c
	  | _ -> assert false
	in
	let result rhs res =
	  List.fold_left (fun rhs (v,src) -> source src :: rhs) rhs res
	in
	List.map 
	  (fun (t, ret) ->
	     let m = mask ret in
	     let (code,_,_) = try List.assoc m masks with Not_found -> assert false in
	     let rhs = 
	       List.fold_left
		 (fun rhs ->
		    function 
		      | Some x -> result rhs x 
		      | None -> rhs
		 ) [] ret in
	     (t,(code,List.rev rhs))
	  )
      in
	     
      let map_prod masks =
	let source res1 res2 v : source -> Dispatch.source' = function
	  | `Catch -> `Catch
	  | `Const c -> `Const c
	  | `Left -> 
	      let v1 = try List.assoc v res1 with Not_found -> assert false in
	      `Left v1
	  | `Right -> 
	      let v2 = try List.assoc v res2 with Not_found -> assert false in
	      `Right v2
	  | `Recompose ->
	      Printf.eprintf "res1:\n";
	      List.iter (fun (v,i) -> Printf.eprintf "v=%s;i=%i\n" v i) res1;
	      Printf.eprintf "res2:\n";
	      List.iter (fun (v,i) -> Printf.eprintf "v=%s;i=%i\n" v i) res2;
	      flush stderr;

	      let v1 = try List.assoc v res1 with Not_found -> assert false in
	      let v2 = try List.assoc v res2 with Not_found -> assert false in
	      `Recompose (v1,v2)
	  | _ -> assert false
	in
	let result rhs res1 res2 (res,(i,j)) =
	  let res1 = match res1.(i) with Some r -> r | None -> assert false in
	  let res2 = match res2.(j) with Some r -> r | None -> assert false in
	  List.fold_left 
	    (fun rhs (v,src) -> source res1 res2 v src :: rhs) rhs res
	in
	map_disp 
	  (fun res1 -> 
	     map_disp 
	     (fun res2 ret -> 
		let m = mask ret in
		let (code,_,_) = List.assoc m masks in
		let rhs = 
		  List.fold_left
		    (fun rhs ->
		       function 
			 | Some x -> result rhs res1 res2 x 
			 | None -> rhs
		    ) [] ret in
		(code,List.rev rhs)
	     )
	  )
      in	
      
      let masks = 
	let accu = ref [] in
	let acc r = accu := (mask r) :: !accu in
	List.iter (fun (_,r) -> acc r) basic;
	List.iter 
	  (fun (_,(_,l)) -> List.iter (fun (_,r) -> acc r) l) 
	  (snd prod);
	
	let rec it_record_opt : Dispatch.record option -> unit = 
	  function  None -> () | Some r -> it_record r
	and it_record : Dispatch.record -> unit = function
	  | `Result r -> acc r
	  | `Label (_,d,ro) -> it_record_disp d;  it_record_opt ro
	and it_record_disp (_,l) = List.iter (fun (_,r) -> it_record r) l
	in
	it_record_opt record;
	List.map 
	  (fun (m,i) -> let (arity,r) = alloc m in (m,(i,arity,r))) 
	  (num 0 (SortedList.from_list !accu))
      in
      incr id;
      let disp =
	{ 
	  Dispatch.id = !id;
	  Dispatch.fv = List.map (fun p -> p.nfv) pl;
	  Dispatch.masks = masks;
	  Dispatch.basic = basic;
	  Dispatch.prod = prod;
	  Dispatch.record = record;
	  Dispatch.basic' = None;
	  Dispatch.prod' = None;
	}
      in
      dispatchers := D.add (t,pl) disp !dispatchers;
      disp.Dispatch.basic' <- Some (map_basic masks basic);
      disp.Dispatch.prod' <- Some (map_prod masks prod);
      disp
1141

1142

1143
1144
1145
  let to_print = ref []
  let memo = ref []
  let count = ref 0
1146

1147
1148
  let print_fv ppf fv =
    List.iter (fun x -> Format.fprintf ppf "{%s}" x) fv
1149

1150
1151
  let res_basic x = function
    | `Catch -> "v"
1152
1153
1154
    | `Const c -> 
	Types.Print.print_const Format.str_formatter c;
	Format.flush_str_formatter ()
1155
    | _ -> assert false
1156

1157
1158
1159
1160
1161
1162
  let res_prod i j x res = 
    match res with
      | `Left -> Printf.sprintf "l%i_%s" i x
      | `Right -> Printf.sprintf "r%i_%s" j x
      | `Recompose -> Printf.sprintf "(l%i_%s,r%i_%s)" i x j x
      | _ -> res_basic x res
1163

1164
1165
1166
1167
1168
  let res_record m x res = 
    match res with
      | `Field l -> 
	  Printf.sprintf "f%s_%i_%s" (Types.label_name l) (List.assoc l m) x
      | _ -> res_basic x res
1169

1170

1171
1172
  let print_mask ppf =
    List.iter (fun b -> Format.fprintf ppf "%i" (if b then 1 else 0))
1173

1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
  let compute_vars mask pl =
    List.fold_right2
      (fun (b,i) p acc -> 
	 if b then List.fold_right (fun v acc -> (i,v)::acc) p.v acc
	 else acc
      )
      (num 0 mask) pl []

  let compute_result f result =
    List.fold_right
      (function
	 | None -> (fun acc -> acc)
	 | Some x ->
	     let (r,res) = f x in
	     List.fold_right (fun (x,s) acc -> res x s :: acc) r
      )
      result []
1191

1192
1193
1194
1195
1196
1197
1198
  let print_success ppf (mask,pl,pr) =
    let vars = 
      let v = compute_vars mask pl in
      if v = [] then "" else
	let v = List.map (fun (i,v) -> Format.sprintf "%s%i_%s" pr i v) v in
	" (" ^ String.concat ", " v ^ ")" in
    Format.fprintf ppf "`S%a%s" print_mask mask vars
1199

1200
1201
1202
1203
  let print_result f ppf result =
    let res = compute_result f result in
    let res = if res = [] then "" else " (" ^ String.concat ", " res ^ ")" in
    Format.fprintf ppf "`S%a%s" print_mask (mask result) res
1204
1205


1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
  let print_source' ppf = function
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
    | `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i

  let print_result' ppf (code,bindings) =
    Format.fprintf ppf "C%i ( " code;
    List.iter (print_source' ppf) bindings;
    Format.fprintf ppf ")"

  let no t pl =
    let pl = List.map (fun p -> normal (restrict t p)) pl in
1221
1222
1223
1224
1225
1226
1227
1228
1229
    try List.assoc (t,pl) !memo 
    with Not_found ->
      incr count;
      let d = dispatch t pl in
      memo := ((t,pl),!count) :: !memo;
      to_print := (!count, d) :: !to_print;
      !count

  let rec show ppf num d =
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
    List.iter 
      (fun (m,(i,arity,res)) -> 
	 Format.fprintf ppf "[%i] arity=%i" i arity;
	 Array.iter (function
		      | None -> Format.fprintf ppf " O"
		      | Some r -> 
			  Format.fprintf ppf " ( ";
			  List.iter (fun (v,i) ->
				       Format.fprintf ppf "%s " v)
			    r;
			  Format.fprintf ppf ")"
		   ) res;
	   Format.fprintf ppf "@\n"
      ) 
      d.Dispatch.masks;
    
1246
    Format.fprintf ppf "let matcher_%i v = match v with@\n" num;
1247
1248
    (match d.Dispatch.prod' with Some p -> show_prod ppf p | None -> assert false);
    (match d.Dispatch.basic' with Some p -> show_basic ppf p | None -> assert false);
1249
1250
1251
    show_record ppf d.Dispatch.record;
    Format.fprintf ppf "@\n"

1252
(*
1253
1254
1255
1256
1257
1258
1259
1260
1261
  and show_basic ppf =
    let pr_basic ppf t =
      if Types.subtype any_basic t then Format.fprintf ppf "AnyBasic"
      else Types.Print.print_descr ppf t in
    let case (t,result) = 
      Format.fprintf ppf "  | @[%a@] -> %a@\n" 
	pr_basic t
	(print_result (fun res -> (res,res_basic))) result in
    List.iter case
1262
      
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
  and show_prod ppf = function
    | (_, []) -> ()
    | ((t1,pl1), cases1) ->
	Format.fprintf ppf 
	"  | (v1,v2) -> match matcher_%i v1 with@\n" (no t1 pl1);
	List.iter (case_prod1 ppf pl1) cases1
  and case_prod2 ppf pl2 (mask2, result) =
    Format.fprintf ppf "          | %a -> %a@\n" 
      print_success (mask2,pl2,"r")
      (print_result (fun (res,(i,j)) -> (res,res_prod i j))) result
1273
  and case_prod1 ppf pl1 (mask1, ((t2,pl2), cases2)) =
1274
1275
1276
1277
    Format.fprintf ppf "      | %a -> match matcher_%i v2 with@\n" 
      print_success (mask1,pl1,"l")
      (no t2 pl2);
    List.iter (case_prod2 ppf pl2) cases2
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
*)
  and show_basic ppf =
    let pr_basic ppf t =
      if Types.subtype any_basic t then Format.fprintf ppf "AnyBasic"
      else Types.Print.print_descr ppf t in
    let case (t,result) = 
      Format.fprintf ppf "  | @[%a@] -> %a@\n" 
	pr_basic t
	print_result' result in
    List.iter case

  and show_prod ppf = function
    | (_, []) -> ()
    | (disp1, cases1) ->
	Format.fprintf ppf 
	"  | (v1,v2) -> match matcher_%i v1 with@\n" disp1.Dispatch.id;
	List.iter (case_prod1 ppf) cases1
  and case_prod2 ppf (code2, result) =
    Format.fprintf ppf "          | %i -> %a@\n" 
      code2
      print_result' result
  and case_prod1 ppf (code1, (disp2,cases2)) =
    Format.fprintf ppf "      | %i -> match matcher_%i v2 with@\n" 
      code1
      disp2.Dispatch.id;
    List.iter (case_prod2 ppf) cases2
1304

1305
1306
1307
1308
1309
  and show_record ppf = function
    | None -> ()
    | Some r ->
	Format.fprintf ppf "  | Record r -> @\n";
	Format.fprintf ppf "     @[%a@]@\n" show_record_aux r
1310
1311
1312
1313

  and show_record_aux ppf = function
    | `Result r  ->
	print_result (fun (res,m) -> (res, res_record m)) ppf r
1314
    | `Label (l, ((t,pl), cases), ab) -> 
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
	let ln = Types.label_name l in
	Format.fprintf ppf "match matcher_%i r.%s with@\n" (no t pl) ln;
	if cases <> [] then
	  (
	    let case (mask, rem) =
	      Format.fprintf ppf "  | %a -> @\n    @[%a@]@\n"
		print_success (mask, pl, Printf.sprintf "f%s_" ln)
		show_record_aux rem
	    in
	    List.iter case cases;
	  );
	(match ab with
	   | Some ab ->
	       Format.fprintf ppf 
	      "  | absent -> @\n    @[%a@]@\n" show_record_aux ab
	   | None -> ()
	)
	
	
    
  let show ppf t pl =
    ignore (no t pl);
    let rec loop () = 
      match !to_print with
	| (n,d)::r -> to_print:=r; show ppf n d; loop ()
	| [] -> ()
    in
    loop ()
1343

1344
1345
  let get i =
    fst (List.find (fun (_,j) -> i = j) !memo)
1346

1347
1348
***************************************************************)

1349
end   
1350

1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
(*
  let test_filter t p = 
    let t = Syntax.make_type (Syntax.parse t)
    and p = Syntax.make_pat (Syntax.parse p) in
    let r = Patterns.filter (Types.descr t) p in
    List.iter (fun (v,t) -> 
                 let t = Types.normalize t in
                 Format.fprintf Format.std_formatter "@[%s => %a@]@\n"
                       v Types.Print.print t) r;;
test_filter "[ (1 2 3?)* ]" "[ (x::(1 2) 3?)* ]";;
*)
1362

1363
(*
1364
1365
let pat s = Patterns.descr (Typer.pat (Parser.From_string.pat s));;
let typ s = Types.descr (Typer.typ (Parser.From_string.pat s));;
1366
1367
1368
1369
let f s = Patterns.NF.nf (pat s);;
let show' t l = Patterns.NF.show Format.std_formatter t (List.map f l);;
let show l = show' Types.any l;;
let showt t l = show' (typ t) l;;
1370

1371
 showt " [(`A `B `C?)*] "  [" [ (((x::`A) `B (x::`C))|_)* ] "];;
1372
showt " [(`A)*] "  [" [ (x::`A)* ] "];;
1373

1374
1375
show ["{x=2;y=3}"];;
show [" [((x::1)|(y::2))*] "];;
1376

1377
1378
let g s =
   Patterns.NF.ProdMap.fold (fun k x acc -> (k,x)::acc) (Patterns.NF.left (f s)) [];;
1379

1380
1381
1382
 Patterns.NF.dispatch Types.any [ f "(x,y)" ];;
 Patterns.NF.show Format.std_formatter 0 Types.any [ f "(x,y)" ];;
 Patterns.NF.show Format.std_formatter 0 Types.any [ f "(0--100,x) | (_,(x:=10))" ];;
1383

1384
1385
let t = Types.descr (Syntax.make_type (Syntax.parse "[_*]")) in
Patterns.NF.show Format.std_formatter 0 t [ f "[((x::5)|_)*]" ];;
1386

1387

1388
1389
1390
1391
1392
1393
1394
1395
1396
Patterns.NF.show Format.std_formatter 0 Types.any [ f "(x,y)"; f "(x,y)"];;
Patterns.NF.show Format.std_formatter 0 Types.any [ f "x"; f "y"];;

show [ "((x,_),_)"; "((_,x),_)" ];;
showt " [ (1 3?)* ]" [ " [(x::1 3?)*] " ];;
showt " [ (1 3?)* ]" [ " [(1 (x::3)?)*] " ];;
#install_printer Types.Print.print;;
#install_printer Types.Print.print_descr;;
let (t,[p1;p2]) = Patterns.NF.get 5;;
1397
*)
1398
1399


1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416

(*
#install_printer Types.Print.print_descr;;
let pat s = Patterns.descr (Typer.pat (Parser.From_string.pat s));;
let typ s = Types.descr (Typer.typ (Parser.From_string.pat s));;

let disp t l = 
  let l = Array.of_list (
    List.map (fun p -> Patterns.NF.normal (Patterns.NF.nf (pat p))) l) in
  let t = typ t in
  Patterns.NF.Disp.show Format.std_formatter t l;;

let () = disp "_" ["(x,y,z)"];;

disp "_" ["`A"];;
disp "_" ["((x,y),z) | ((x := 1) & (y := 2), z)"];;
*)