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

4
5
6
(*
To be sure not to use generic comparison ...
*)
7
8
9
10
11
12
let (=) : int -> int -> bool = (==)
let (<) : int -> int -> bool = (<)
let (<=) : int -> int -> bool = (<=)
let (<>) : int -> int -> bool = (<>)
let compare = 1

13

14
(* Syntactic algebra *)
15
(* Constraint: any node except Constr has fv<>[] ... *)
16
type d =
17
  | Constr of Types.descr
18
  | Cup of descr * descr
19
  | Cap of descr * descr
20
  | Times of node * node
21
  | Xml of node * node
22
  | Record of label * node
23
24
  | Capture of id
  | Constant of id * Types.const
25
26
and node = {
  id : int;
27
28
  mutable descr : descr option;
  accept : Types.node;
29
  fv : fv
30
} and descr = Types.descr * fv * d
31

32
33
34
35
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
36
37
38

let printed = ref []
let to_print = ref []
39
let rec print ppf (a,_,d) = 
40
  match d with
41
    | Constr t -> Types.Print.print ppf t
42
43
44
45
46
47
48
49
50
    | 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) -> 
51
	Format.fprintf ppf "{ %a =  P%i }" U.print (LabelPool.value l) n.id;
52
53
	to_print := n :: !to_print
    | Capture x ->
54
	Format.fprintf ppf "%a" U.print (Id.value x)
55
    | Constant (x,c) ->
56
	Format.fprintf ppf "(%a := %a)" U.print (Id.value x) 
57
	  Types.Print.print_const c
58

59
let dump_print ppf =
60
  while !to_print != [] do
61
62
63
64
65
66
67
68
69
70
71
    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
72
73


74
75
76
77
78
let counter = State.ref "Patterns.counter" 0

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

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

85
let constr x = (x,IdSet.empty,Constr x)
86
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
87
88
89
90
91
  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
92
93
94
    in
    raise 
      (Error 
95
	 ("The capture variable " ^ (U.to_string (Id.value x)) ^ 
96
97
	  " should appear on both side of this | pattern"))
  );
98
  (Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
99
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
100
101
102
  if not (IdSet.disjoint fv1 fv2) then (
    match IdSet.pick (IdSet.cap fv1 fv2) with
      | Some x -> 
103
104
	  raise 
	  (Error 
105
	     ("The capture variable " ^ (U.to_string (Id.value x)) ^ 
106
	      " cannot appear on both side of this & pattern"))
107
      | None -> assert false
108
  );
109
  (Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2))
110
let times x y =
111
  (Types.times x.accept y.accept, IdSet.cup x.fv y.fv, Times (x,y))
112
let xml x y =
113
  (Types.xml x.accept y.accept, IdSet.cup x.fv y.fv, Xml (x,y))
114
let record l x = 
115
  (Types.record l x.accept, x.fv, Record (l,x))
116
117
let capture x = (Types.any, IdSet.singleton x, Capture x)
let constant x c = (Types.any, IdSet.singleton x, Constant (x,c))
118

119

120

121
122
123
124

(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
125
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
126
127
let times_res v1 v2 = Types.Positive.times v1 v2

128
(* Try with a hash-table *)
129
module MemoFilter = Map.Make 
130
131
132
133
134
135
  (struct 
     type t = Types.descr * node 
     let compare (t1,n1) (t2,n2) = 
       if n1.id < n2.id then -1 else if n1.id > n2.id then 1 else
       Types.compare_descr t1 t2
   end)
136
137
138

let memo_filter = ref MemoFilter.empty

139
let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
140
(* TODO: avoid is_empty t when t is not changing (Cap) *)
141
142
143
144
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
145
      | Constr _ -> IdMap.empty
146
      | Cup ((a,_,_) as d1,d2) ->
147
	  IdMap.merge cup_res
148
149
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
150
      | Cap (d1,d2) ->
151
	  IdMap.merge cup_res (filter_descr t d1) (filter_descr t d2)
152
153
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
154
155
156
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
157
	  IdMap.singleton c (Types.Positive.ty t)
158
      | Constant (c, cst) ->
159
	  IdMap.singleton c (Types.Positive.ty (Types.constant cst))
160

161
162
163
164
and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
165
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
166
       in
167
       IdMap.merge cup_res accu term
168
169
170
171
172
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


173
and filter_node t p : Types.Positive.v id_map =
174
175
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
176
    let (_,fv,_) as d = descr p in
177
    let res = IdMap.map_from_slist (fun _ -> Types.Positive.forward ()) fv in
178
179
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
180
    IdMap.collide Types.Positive.define res r;
181
182
183
184
185
    r

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
186
  IdMap.get (IdMap.map Types.Positive.solve r)
187
188


189
(* Normal forms for patterns and compilation *)
190

191
192
let min (a:int) (b:int) = if a < b then a else b

193
194
195
let any_basic = Types.Record.or_absent Types.non_constructed


196
197
module Normal : sig 
  type source = 
198
199
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
200
  type result = source id_map
201

202
203
204
205
206
207
  module NodeSet : SortedList.S with type 'a elem = node
  type nnf = unit NodeSet.t * Types.descr

  module NLineBasic : SortedList.S with type 'a elem = result * Types.descr
  module NLineProd : SortedList.S with type 'a elem = result * nnf * nnf

208
  type record =
209
    | RecNolabel of result option * result option
210
    | RecLabel of label * unit NLineProd.t
211
212
213
214
  type t = {
    nfv    : fv;
    ncatchv: fv;
    na     : Types.descr;
215
216
217
    nbasic : unit NLineBasic.t;
    nprod  : unit NLineProd.t;
    nxml   : unit NLineProd.t;
218
    nrecord: record;
219
220
  }

221
  val dummy: t
222
223
  val compare_nf: t -> t -> int

224
225
  val first_label: descr -> label
  val normal: label option -> Types.descr -> node list -> t
226
end = 
227
struct
228

229
  type source = 
230
231
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
232
  type result = source id_map
233

234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
  let compare_source s1 s2 =
    if s1 == s2 then 0 
    else match (s1,s2) with
      | SCatch, _ -> -1 | _, SCatch -> 1
      | SLeft, _ -> -1 | _, SLeft -> 1
      | SRight, _ -> -1 | _, SRight -> 1
      | SRecompose, _ -> -1 | _, SRecompose -> 1
      | SConst c1, SConst c2 -> Types.compare_const c1 c2

  let hash_source = function
    | SCatch -> 1
    | SLeft -> 2
    | SRight -> 3
    | SRecompose -> 4
    | SConst c -> Types.hash_const c
    
  let compare_result r1 r2 =
    IdMap.compare compare_source r1 r2

  let hash_result r =
    IdMap.hash hash_source r


  module NodeSet = 
    SortedList.Make(
      struct
	type 'a t = node
	let compare n1 n2 = n1.id - n2.id
	let equal n1 n2 = n1.id == n2.id
	let hash n = n.id
      end
    )

  type nnf = unit NodeSet.t * Types.descr (* pl,t;   t <= \accept{pl} *)

  let compare_nnf (l1,t1) (l2,t2) =
    let c = NodeSet.compare l1 l2 in if c <> 0 then c
    else Types.compare_descr t1 t2

  let hash_nnf (l,t) =
    (NodeSet.hash l) + 17 * (Types.hash_descr t)

  module NLineBasic = 
    SortedList.Make(
      struct
	type 'a t = result * Types.descr
	let compare (r1,t1) (r2,t2) =
	  let c = compare_result r1 r2 in if c <> 0 then c
	  else Types.compare_descr t1 t2
283
	let equal x y = compare x y == 0
284
285
286
287
288
289
290
291
292
293
294
295
	let hash (r,t) = hash_result r + 17 * Types.hash_descr t
      end
    )

  module NLineProd = 
    SortedList.Make(
      struct
	type 'a t = result * nnf * nnf
	let compare (r1,x1,y1) (r2,x2,y2) =
	  let c = compare_result r1 r2 in if c <> 0 then c
	  else let c = compare_nnf x1 x2 in if c <> 0 then c
	  else compare_nnf y1 y2
296
	let equal x y = compare x y == 0
297
298
299
300
301
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

302
  type record =
303
    | RecNolabel of result option * result option
304
    | RecLabel of label * unit NLineProd.t
305
  type t = {
306
    nfv    : fv;
307
    ncatchv: fv;
308
    na     : Types.descr;
309
310
311
    nbasic : unit NLineBasic.t;
    nprod  : unit NLineProd.t;
    nxml   : unit NLineProd.t;
312
    nrecord: record
313
  }
314

315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
  let compare_nf t1 t2 =
    if t1 == t2 then 0
    else
      (* TODO: reorder; remove comparison of nfv ? *)
      let c = IdSet.compare t1.nfv t2.nfv in if c <> 0 then c 
      else let c = IdSet.compare t1.ncatchv t2.ncatchv in if c <> 0 then c
      else let c = Types.compare_descr t1.na t2.na in if c <> 0 then c
      else let c = NLineBasic.compare t1.nbasic t2.nbasic in if c <> 0 then c
      else let c = NLineProd.compare t1.nprod t2.nprod in if c <> 0 then c
      else let c = NLineProd.compare t1.nxml t2.nxml in if c <> 0 then c
      else match t1.nrecord, t2.nrecord with
	| RecNolabel (s1,n1), RecNolabel (s2,n2) ->
	    let c = match (s1,s2) with
	      | None,None -> 0
	      | Some r1, Some r2 -> compare_result r1 r2
	      | None, _ -> -1
	      | _, None -> 1 in
	    if c <> 0 then c 
	    else (match (n1,n2) with
	      | None,None -> 0
	      | Some r1, Some r2 -> compare_result r1 r2
	      | None, _ -> -1
	      | _, None -> 1)
	| RecNolabel (_,_), _ -> -1
	| _, RecNolabel (_,_) -> 1
	| RecLabel (l1,p1), RecLabel (l2,p2) ->
	    let c = LabelPool.compare l1 l2 in if c <> 0 then c
	    else NLineProd.compare p1 p2
343

344
  let fus = IdMap.union_disj
345

346
347
348
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
349
350
351
      nbasic = NLineBasic.empty; 
      nprod = NLineProd.empty; 
      nxml = NLineProd.empty;
352
      nrecord = (match lab with 
353
		   | Some l -> RecLabel (l,NLineProd.empty)
354
		   | None -> RecNolabel (None,None))
355
    }
356
  let dummy = nempty None
357
358
359
360
361
362


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
363
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
364
      na      = Types.cup nf1.na nf2.na;
365
366
367
      nbasic  = NLineBasic.cup nf1.nbasic nf2.nbasic;
      nprod   = NLineProd.cup nf1.nprod nf2.nprod;
      nxml    = NLineProd.cup nf1.nxml nf2.nxml;
368
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
369
		   | RecLabel (l1,r1), RecLabel (l2,r2) -> 
370
		       (* assert (l1 = l2); *) RecLabel (l1, NLineProd.cup r1 r2)
371
		   | RecNolabel (x1,y1), RecNolabel (x2,y2) -> 
372
373
		       RecNolabel((if x1 == None then x2 else x1),
				(if y1 == None then y2 else y1))
374
		   | _ -> assert false)
375
376
377
    }

  let double_fold f l1 l2 =
378
379
380
381
382
383
    List.fold_left 
      (fun accu x1 -> List.fold_left (fun accu x2 -> f accu x1 x2) accu l2)
      [] l1

  let double_fold_prod f l1 l2 =
    double_fold f (NLineProd.get l1) (NLineProd.get l2)
384
385
	 
  let ncap nf1 nf2 =
386
    let prod accu (res1,(pl1,t1),(ql1,s1)) (res2,(pl2,t2),(ql2,s2)) =
387
388
389
390
      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
391
392
	  (fus res1 res2, (NodeSet.cup pl1 pl2,t),(NodeSet.cup ql1 ql2,s)) 
	  :: accu
393
394
395
396
397
398
    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
399
    let record r1 r2 = match r1,r2 with
400
      | RecLabel (l1,r1), RecLabel (l2,r2) ->
401
	  (* assert (l1 = l2); *)
402
	  RecLabel(l1, NLineProd.from_list (double_fold_prod prod r1 r2))
403
      | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
404
405
406
407
408
409
	  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
410
	  RecNolabel (x,y)
411
      | _ -> assert false
412
    in
413
414
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
415
      na = Types.cap nf1.na nf2.na;
416
417
418
419
420
421
      nbasic = NLineBasic.from_list (double_fold basic 
				       (NLineBasic.get nf1.nbasic) 
				       (NLineBasic.get nf2.nbasic));
      nprod = NLineProd.from_list (double_fold_prod prod nf1.nprod nf2.nprod);
      nxml = NLineProd.from_list (double_fold_prod prod nf1.nxml nf2.nxml);
      nrecord = record nf1.nrecord nf2.nrecord;
422
423
    }

424
425
426
427
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

428
  let empty_res = IdMap.empty
429

430
  let ntimes lab acc p q = 
431
432
433
    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 
434
    { nempty lab with 
435
	nfv = IdSet.cup p.fv q.fv; 
436
	na = acc;
437
	nprod = NLineProd.singleton (src, nnode p, nnode q);
438
439
    }

440
  let nxml lab acc p q = 
441
442
443
    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 
444
    { nempty lab with 
445
	nfv = IdSet.cup p.fv q.fv; 
446
	na = acc;
447
	nxml =  NLineProd.singleton (src, nnode p, nnode q);
448
449
    }
    
450
451
452
453
454
455
456
457
458
459
  let nrecord lab acc l p =
    match lab with
      | None -> assert false
      | Some label ->
	  assert (label <= l);
	  if l == label then
	    let src = IdMap.constant SLeft p.fv in
	    { nempty lab with
		nfv = p.fv;
		na = acc;
460
		nrecord = RecLabel(label, 
461
				 NLineProd.singleton (src,nnode p, ncany))}
462
463
464
465
466
467
468
469
	  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;
470
471
472
473
		nrecord = 
		      RecLabel(label,
		        NLineProd.singleton(src,nc Types.Record.any_or_absent, 
 			 nnode p') )}
474
475
476
	  

  let nconstr lab t =
477
478
    let aux l = NLineProd.from_list
		(List.map (fun (t1,t2) -> empty_res, nc t1,nc t2) l) in
479
480
481
482
    let record = 
      match lab with
	| None ->
	    let (x,y) = Types.Record.empty_cases t in
483
	    RecNolabel ((if x then Some empty_res else None), 
484
485
		      (if y then Some empty_res else None))
	| Some l ->
486
	    RecLabel (l,aux (Types.Record.split_normal t l))
487
488
    in	      
    { nempty lab with
489
	na = t;
490
	nbasic = NLineBasic.singleton (empty_res, Types.cap t any_basic);
491
492
493
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
494
495
    }

496
  let nconstant lab x c = 
497
498
499
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
500
      na = Types.any;
501
502
503
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
504
      nrecord = match lab with
505
	| None -> RecNolabel (Some l, Some l)
506
	| Some lab -> 
507
508
509
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
				 ncany))
510
511
    }

512
  let ncapture lab x = 
513
514
515
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
516
      na = Types.any;
517
518
519
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
520
      nrecord = match lab with
521
	| None -> RecNolabel (Some l, Some l)
522
	| Some lab -> 
523
524
525
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
			         ncany))
526
527
    }

528
  let rec nnormal lab (acc,fv,d) =
529
    if Types.is_empty acc 
530
    then nempty lab
531
    else match d with
532
533
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
534
      | Cup ((acc1,_,_) as p,q) -> 
535
536
537
538
539
540
541
542
543
544
545
546
547
	  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 
548
    then LabelPool.dummy_max
549
550
551
552
553
554
    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
555
      | _ -> LabelPool.dummy_max
556

557
558
559
   
  let remove_catchv n =
    let ncv = n.ncatchv in
560
561
562
563
    let nlinesbasic l = 
      NLineBasic.map (fun (res,x) -> (IdMap.diff res ncv,x)) l in
    let nlinesprod l  = 
      NLineProd.map (fun (res,x,y) -> (IdMap.diff res ncv,x,y)) l in
564
    { nfv     = IdSet.diff n.nfv ncv;
565
566
      ncatchv = n.ncatchv;
      na      = n.na;
567
568
569
      nbasic  = nlinesbasic n.nbasic;
      nprod   = nlinesprod n.nprod;
      nxml    = nlinesprod n.nxml;
570
      nrecord = (match n.nrecord with
571
		   | RecNolabel (x,y) ->
572
573
574
575
576
577
		       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
578
		       RecNolabel (x,y)
579
		   | RecLabel (lab,l) -> RecLabel (lab, nlinesprod l))
580
581
    }

582
  let normal l t pl =
583
    remove_catchv
584
585
586
587
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
588
end
589
590


591
592
module Compile = 
struct
593
  type actions =
594
595
    | AIgnore of result
    | AKind of actions_kind
596
  and actions_kind = {
597
    basic: (Types.descr * result) list;
598
599
    atoms: result Atoms.map;
    chars: result Chars.map;
600
    prod: result dispatch dispatch;
601
    xml: result dispatch dispatch;
602
603
604
    record: record option;
  }
  and record = 
605
    | RecLabel of label * result dispatch dispatch
606
    | RecNolabel of result option * result option
607
      
608
  and 'a dispatch =
609
610
611
612
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
613
614

  and result = int * source array
615
  and source = 
616
617
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
618
619
620
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
621
      (int * int id_map) list
622
623

  and interface =
624
625
    [ `Result of int
    | `Switch of interface * interface
626
627
628
629
630
631
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
632
    label : label option;
633
634
    interface : interface;
    codes : return_code array;
635
636
    mutable actions : actions option;
    mutable printed : bool
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
  let equal_array f a1 a2 =
    let rec aux i = (i < 0) || ((f a1.(i) a2.(i)) && (aux (i - 1))) in
    let l1 = Array.length a1 and l2 = Array.length a2 in
    (l1 == l2) && (aux (l1 - 1))

  let equal_source s1 s2 =
    (s1 == s2) || match (s1,s2) with
      | Const x, Const y -> Types.equal_const x y 
      | Left x, Left y -> x == y
      | Right x, Right y -> x == y
      | Recompose (x1,x2), Recompose (y1,y2) -> (x1 == y1) && (x2 == y2)
      | _ -> false

  let equal_result (r1,s1) (r2,s2) =
    (r1 == r2) && (equal_array equal_source s1 s2)

  let equal_result_dispatch d1 d2 =
    (d1 == d2) || match (d1,d2) with
      | Dispatch (d1,a1), Dispatch (d2,a2) -> (d1 == d2) && (equal_array equal_result a1 a2)
      | TailCall d1, TailCall d2 -> d1 == d2
      | Ignore a1, Ignore a2 -> equal_result a1 a2
      | _ -> false


663
664
  let array_for_all f a =
    let rec aux f a i =
665
      if i == Array.length a then true
666
667
668
669
670
671
      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 =
672
      if i == Array.length a then true
673
674
675
676
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

677
  let combine_kind basic prod xml record =
678
679
680
681
682
683
684
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
685
686
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
687
	| _ -> raise Exit in
688
      let rs = match xml with
689
690
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
691
	| _ -> raise Exit in
692
693
      let rs = match record with
	| None -> rs
694
695
	| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
	| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
696
697
	| _ -> raise Exit in
      match rs with
698
	| ((_, ret) as r) :: rs when 
699
	    List.for_all ( equal_result r ) rs 
700
	    && array_for_all 
701
702
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
703
704
	| _ -> raise Exit
    )
705
706
707
708
709
710
711
712
713
714
715
    with Exit -> 
      AKind 
      { basic = basic;
	atoms = 
	   Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic);
	chars = 
	   Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic);
	prod = prod; 
	xml = xml; 
	record = record }
      
716
717
  let combine f (disp,act) =
    if Array.length act == 0 then Impossible
718
    else
719
720
      if (array_for_all (fun (_,ar,_) -> ar == 0) disp.codes) 
	 && (array_for_all ( f act.(0) ) act) then
721
	   Ignore act.(0)
722
      else
723
	Dispatch (disp, act)
724
725
726


  let detect_right_tail_call = function
727
    | Dispatch (disp,branches) 
728
729
730
	when
	  array_for_all_i
	    (fun i (code,ret) ->
731
	       (i == code) && 
732
733
	       (array_for_all_i 
		  (fun pos -> 
734
		     function Right j when pos == j -> true | _ -> false)
735
736
737
		  ret
	       )
	    ) branches
738
	  -> TailCall disp
739
740
741
    | x -> x

  let detect_left_tail_call = function
742
    | Dispatch (disp,branches)
743
744
745
746
	when
	  array_for_all_i
	    (fun i -> 
	       function 
747
		 | Ignore (code,ret) ->
748
		     (i == code) &&
749
750
		     (array_for_all_i 
			(fun pos -> 
751
			   function Left j when pos == j -> true | _ -> false)
752
753
754
755
756
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
757
	 TailCall disp
758
759
    | x -> x
   
760
761
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
762
		 
763
764
765
766
767
768
  module NfMap = Map.Make(
    struct 
      type t = Normal.t
      let compare = Normal.compare_nf
    end)

769
770
  module DispMap = Map.Make(
    struct
771
      type t = Types.descr * Normal.t array
772
773
774
775
776
777
778
779
780
781
782
783

      let rec compare_rec a1 a2 i =
	if i < 0 then 0 
	else
	  let c = Normal.compare_nf a1.(i) a2.(i) in
	  if c <> 0 then c else compare_rec a1 a2 (i - 1)
	  
      let compare (t1,a1) (t2,a2) =
	let c = Types.compare_descr t1 t2 in if c <> 0 then c 
	else let l1 = Array.length a1 and l2 = Array.length a2 in
	if l1 < l2 then -1 else if l1 > l2 then 1
	else compare_rec a1 a2 (l1 - 1)
784
785
    end
  )
786
787

    (* Try with a hash-table ! *)
788
    
789
  let dispatchers = ref DispMap.empty
790
		      
791
  let dispatcher t pl lab : dispatcher =
792
793
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
794
      let nb = ref 0 in
795
796
      let codes = ref [] in
      let rec aux t arity i accu = 
797
798
	if Types.is_empty t then `None
	else
799
	  if i == Array.length pl 
800
	  then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
801
802
	  else
	    let p = pl.(i) in
803
	    let tp = p.Normal.na in
804
	    let v = p.Normal.nfv in
805
(*	    let tp = Types.normalize tp in *)
806
	    let accu' = (i,IdMap.num arity v) :: accu in
807
	    `Switch 
808
	      (
809
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
810
	       aux (Types.diff t tp) arity (i+1) accu
811
812
	      )
      in
813
      let iface = aux t 0 0 [] in
814
815
      let res = { id = !cur_id; 
		  t = t;
816
		  label = lab;
817
		  pl = pl;
818
		  interface = iface;
819
		  codes = Array.of_list (List.rev !codes);
820
		  actions = None; printed = false } in
821
822
823
824
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
825
826
  let find_code d a =
    let rec aux i = function
827
828
      | `Result code -> code
      | `None -> assert false
829
      | `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes
830
      | `Switch (_,no) -> aux (i + 1) no
831
832
833
834
    in
    aux 0 d.interface

  let create_result pl =
835
836
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
837
838
839
840
841
842

  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)
    
843
  let conv_source_basic s = match s with
844
845
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
846
847
    | _ -> assert false

848
  let assoc v l =
849
    try IdMap.assoc v l with Not_found -> -1
850

851
  let conv_source_prod left right v s = match s with
852
853
854
855
856
    | 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)
857
858

  let dispatch_basic disp : (Types.descr * result) list =
859
(* TODO: try other algo, using disp.codes .... *)
860
861
862
863
    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
864
      Array.iteri (fun i -> Normal.NLineBasic.iter (aux i)) pl;
865
      Types.DescrSList.Map.get (Types.DescrSList.Map.from_list (@) !accu) in
866

867
    let t = Types.cap any_basic disp.t in
868
    let accu = ref [] in
869
    let rec aux (success : (int * Normal.result) list) t l = 
870
871
872
      if Types.non_empty t 
      then match l with
	| [] ->
873
874
875
876
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
877
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
878
879
880
881
	    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
882
    in
883
    aux [] t tests;
884
885
886
    !accu


887
  let get_tests pl f t d post =
888
889
    let accu = ref [] in
    let aux i x = 
890