patterns.ml 22.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
type capture = string
type fv = capture SortedList.t

exception IllFormedCup of fv * fv
exception IllFormedCap of fv * fv

(* Syntactic algebra *)

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

let make =
  let counter = ref 0 in
  fun fv ->
    incr counter;
    { id = !counter; descr = None; accept = Types.make (); fv = fv }

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

let constr x = (Types.descr x,[],Constr x)
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
  if fv1 <> fv2 then raise (IllFormedCup (fv1,fv2));
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
  if not (SortedList.disjoint fv1 fv2) then raise (IllFormedCap (fv1,fv2));
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2))
let times x y =
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
let record l x = 
  (Types.record l false x.accept, x.fv, Record (l,x))
let capture x = (Types.any, [x], Capture x)
let constant x c = (Types.any, [x], Constant (x,c))


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


(* Static semantics *)

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

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

let memo_filter = ref MemoFilter.empty

let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
      | Constr _ -> []
      | Cup ((a,_,_) as d1,d2) ->
	  SortedMap.union cup_res
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
      | Cap (d1,d2) ->
	  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)
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
	  [(c, Types.Positive.ty t)]
      | Constant (c, cst) ->
	  [(c, Types.Positive.ty (Types.constant cst))]

and filter_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 *)

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

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

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


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

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

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


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

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

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

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

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

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

  let constr t =
    { v = [];
      a = t;
253
254
255
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
      record = [ ([],[]), Types.cap t Types.Record.any ];
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
    }

(* 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


274
275
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
  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
313
314
315
    { nfv     = nf.v;
      na      = nf.a;
      nbasic  = basic nf.basic;
316
317
318
319
      nprod   = prod nf.prod;
      nrecord = record nf.record;
    }

320
end
321
322


323
324
325
326
327
328
329
330
331
332
module Compile = 
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 ]
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
  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 return_code = 
      Types.descr * int *   (* accepted type, arity *)
      (int * (capture, int) SortedMap.t) list

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

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
    interface : interface;
    codes : return_code array;
    mutable actions : actions option
  }
      
  let cur_id = ref 0
		 
362
363
  module DispMap = Map.Make(
    struct
364
      type t = Types.descr * Normal.t array
365
366
367
      let compare = compare
    end
  )
368
    
369
  let dispatchers = ref DispMap.empty
370
371
372
		      
  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)
    
373
374
375
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
376
377
378
379
      let nb = ref 0 in
      let rec aux t arity i = 
	if Types.is_empty t then `None
	else
380
	  if i = Array.length pl 
381
	  then (incr nb; `Result (!nb - 1, t, arity))
382
383
	  else
	    let p = pl.(i) in
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
	    let tp = p.Normal.na in
	    let v = p.Normal.nfv in
	    `Switch 
	      (num arity v,
	       aux (Types.cap t tp) (arity + (List.length v)) (i+1),
	       aux (Types.diff t tp) arity (i+1)
	      )
      in
      let iface = aux t 0 0 in
      let codes = Array.create !nb (Types.empty,0,[]) in
      let rec aux i accu = function
	| `None -> ()
	| `Switch (pos, yes, no) -> 
	    aux (i + 1) ((i,pos) :: accu) yes; aux (i + 1) accu no
	| `Result (code,t,arity) -> codes.(code) <- (t,arity, accu)
399
      in
400
      aux 0 [] iface;
401
402
403
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
404
405
		  interface = iface;
		  codes = codes;
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
		  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

421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
  let find_code d a =
    let rec aux i = function
      | `Result (code,_,_) -> code
      | `None -> assert false
      | `Switch (_,yes,no) ->
	  match a.(i) with Some _ -> aux (i + 1) yes | None -> aux (i + 1) no
    in
    aux 0 d.interface

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

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

446
447
448
449
450
451
  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
    | `Left -> `Left (List.assoc v left)
    | `Right -> `Right (List.assoc v right)
    | `Recompose -> `Recompose (List.assoc v left, List.assoc v right)
    | _ -> assert false
452

453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
  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 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
468
    let accu = ref [] in
469
    let rec aux (success : (int * Normal.result) list) t l = 
470
471
472
      if Types.non_empty t 
      then match l with
	| [] ->
473
474
475
476
477
478
479
480
481
	    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
482
    in
483
    aux [] t tests;
484
485
486
487
488
489
490
491
492
    !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) ->
493
		   let p = Normal.normal (Normal.restrict t p) in
494
495
496
497
498
499
500
		   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
501
    let result (t,_,m) =
502
503
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
504
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
505
506
      d t selected unselect
    in
507
    let res = Array.map result disp.codes in
508
509
510
511
    (disp,res)



512
513
  let rec dispatch_prod disp =
    let pl = Array.map (fun p -> p.Normal.nprod) disp.pl in
514
515
516
517
518
519
520
521
522
523
524
525
    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 _ =
526
527
528
    let aux_final (ret2, (ret1, res)) =  
      List.map (conv_source_prod ret1 ret2) res in
    return disp pl aux_final
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


  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 rec dispatch_record disp : record option =
562
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
563
564
565
566
567
568
569
570
571
    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 -> 
572
573
574
575
	  let aux_final (res, catch, x) =
	    assert (x = `Success);
	    List.map (conv_source_record catch) res in
	  `Result (return disp pl aux_final)
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
      | 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
635
636
637
      | s :: rem -> 
	  Format.fprintf ppf "%a," print_source s; 
	  print_result ppf rem
638
639
    in
    let print_ret ppf (code,ret) = 
640
641
      Format.fprintf ppf "$%i" code;
      if ret <> [] then Format.fprintf ppf "(%a)" print_result ret in
642
    let print_lhs ppf (code,prefix,d) =
643
      let arity = match d.codes.(code) with (_,a,_) -> a in
644
645
646
647
648
649
650
      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) =
651
      Format.fprintf ppf " | %a -> %a@\n"
652
653
654
655
656
	Types.Print.print_descr t
	print_ret ret
    in
    let print_prod2 (d,rem) =
      queue d;
657
      Format.fprintf ppf "        match v2 with disp_%i@\n" d.id;
658
659
      Array.iteri 
	(fun code r ->
660
	   Format.fprintf ppf "        | %a -> %a\n" 
661
662
663
664
665
666
667
668
669
670
671
672
	     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 ->
673
             Format.fprintf ppf "      | %a -> @\n"
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
	     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;
717
718
719
720
	  let print_code code (t, arity, m) =
	    Format.fprintf ppf "  Returns $%i(arity=%i) for [%a]" 
	      code arity
	      Types.Print.print_descr t;
721
(*
722
723
724
	       List.iter
	       (fun (i,b) ->
		      Format.fprintf ppf "[%i:" i;
725
726
727
		      List.iter 
			(fun (v,i) ->  Format.fprintf ppf "%s=>%i;" v i)
			b;
728
		      Format.fprintf ppf "]"
729
730
	       ) m; 
*)
731
732
733
734
	       Format.fprintf ppf "@\n";
	  in
	  Array.iteri print_code d.codes;
	  Format.fprintf ppf "let disp_%i = function@\n" d.id;
735
	  print_actions ppf (actions d);
736
	  Format.fprintf ppf "====================================@\n";
737
738
739
740
741
742
743
	  print_dispatchers ppf

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

744
745
  type normal = Normal.t
  let normal p = Normal.normal (Normal.nf p)
746

747
end
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762


(*
  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?)* ]";;
*)

(*
763
764
disp " [(`A `B `C?)*] "  [" [ (((x::`A) `B (x::`C))|_)* ] "];;
disp " [(`A)*] "  [" [ (x::`A)* ] "];;
765

766
767
disp "_" ["{x=`A;y=`B}"];;
disp "_" [" [((x::1)|(y::2))*] "];;
768

769
770
771
disp "_" [ "((x,_),_)"; "((_,x),_)" ];;
disp " [ (1 3?)* ]" [ " [(x::1 3?)*] " ];;
disp " [ (1 3?)* ]" [ " [(1 (x::3)?)*] " ];;
772
*)
773
774


775
776
777
778
779
780
781
782

(*
#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 (
783
    List.map (fun p -> Patterns.Compile.normal (pat p)) l) in
784
  let t = typ t in
785
  Patterns.Compile.show Format.std_formatter t l;;
786
787
788
789
790
791

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

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