patterns.ml 34.8 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
40
let rec print ppf (a,_,d) = 
(*  Format.fprintf ppf "[%a]" Types.Print.print_descr a; *)
41
42
43
44
45
46
47
48
49
50
51
  match d with
    | Constr t -> Types.Print.print_descr ppf t
    | Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
    | Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
    | Times (n1,n2) -> 
	Format.fprintf ppf "(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Xml (n1,n2) -> 
	Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Record (l,n) -> 
52
	Format.fprintf ppf "{ %s =  P%i }" (LabelPool.value l) n.id;
53
54
	to_print := n :: !to_print
    | Capture x ->
55
	Format.fprintf ppf "%s" (Id.value x)
56
    | Constant (x,c) ->
57
58
	Format.fprintf ppf "(%s := %a)" (Id.value x) 
	  Types.Print.print_const c
59

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


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

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

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

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

120

121

122
123
124
125

(* Static semantics *)

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

129
(* Try with a hash-table *)
130
module MemoFilter = Map.Make 
131
132
133
134
135
136
  (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)
137
138
139

let memo_filter = ref MemoFilter.empty

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

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


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

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


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

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

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

200
201
202
203
204
205
  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

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

219
  val dummy: t
220
221
  val compare_nf: t -> t -> int

222
  val any_basic: Types.descr
223
224
  val first_label: descr -> label
  val normal: label option -> Types.descr -> node list -> t
225
end = 
226
struct
227
228
229
230
231
232
  let any_basic = 
    Types.Record.or_absent
      (Types.neg (List.fold_left Types.cup Types.empty
		    [Types.Product.any_xml;
		     Types.Product.any;
		     Types.Record.any]))
233
234


235
  type source = 
236
237
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
238
  type result = source id_map
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
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
  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 rec compare_nodesl l1 l2 =
    if l1 == l2 then 0 
    else match (l1,l2) with
      | p1::l1, p2::l2 ->
	  if p1.id < p2.id then -1
	  else if p1.id > p2.id then 1
	  else compare_nodesl l1 l2
      | [], _ -> -1
      | _ -> 1
*)

  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
301
	let equal x y = compare x y == 0
302
303
304
305
306
307
308
309
310
311
312
313
	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
314
	let equal x y = compare x y == 0
315
316
317
318
319
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

320
  type record =
321
    | RecNolabel of result option * result option
322
    | RecLabel of label * unit NLineProd.t
323
  type t = {
324
    nfv    : fv;
325
    ncatchv: fv;
326
    na     : Types.descr;
327
328
329
    nbasic : unit NLineBasic.t;
    nprod  : unit NLineProd.t;
    nxml   : unit NLineProd.t;
330
    nrecord: record
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
  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
361

362
  let fus = IdMap.union_disj
363

364
365
366
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
367
368
369
      nbasic = NLineBasic.empty; 
      nprod = NLineProd.empty; 
      nxml = NLineProd.empty;
370
      nrecord = (match lab with 
371
		   | Some l -> RecLabel (l,NLineProd.empty)
372
		   | None -> RecNolabel (None,None))
373
    }
374
  let dummy = nempty None
375
376
377
378
379
380


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
381
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
382
      na      = Types.cup nf1.na nf2.na;
383
384
385
      nbasic  = NLineBasic.cup nf1.nbasic nf2.nbasic;
      nprod   = NLineProd.cup nf1.nprod nf2.nprod;
      nxml    = NLineProd.cup nf1.nxml nf2.nxml;
386
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
387
		   | RecLabel (l1,r1), RecLabel (l2,r2) -> 
388
		       (* assert (l1 = l2); *) RecLabel (l1, NLineProd.cup r1 r2)
389
		   | RecNolabel (x1,y1), RecNolabel (x2,y2) -> 
390
391
		       RecNolabel((if x1 == None then x2 else x1),
				(if y1 == None then y2 else y1))
392
		   | _ -> assert false)
393
394
395
    }

  let double_fold f l1 l2 =
396
397
398
399
400
401
    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)
402
403
	 
  let ncap nf1 nf2 =
404
    let prod accu (res1,(pl1,t1),(ql1,s1)) (res2,(pl2,t2),(ql2,s2)) =
405
406
407
408
      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
409
410
	  (fus res1 res2, (NodeSet.cup pl1 pl2,t),(NodeSet.cup ql1 ql2,s)) 
	  :: accu
411
412
413
414
415
416
    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
417
    let record r1 r2 = match r1,r2 with
418
      | RecLabel (l1,r1), RecLabel (l2,r2) ->
419
	  (* assert (l1 = l2); *)
420
	  RecLabel(l1, NLineProd.from_list (double_fold_prod prod r1 r2))
421
      | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
422
423
424
425
426
427
	  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
428
	  RecNolabel (x,y)
429
      | _ -> assert false
430
    in
431
432
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
433
      na = Types.cap nf1.na nf2.na;
434
435
436
437
438
439
      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;
440
441
    }

442
443
444
445
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

446
  let empty_res = IdMap.empty
447

448
  let ntimes lab acc p q = 
449
450
451
    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 
452
    { nempty lab with 
453
	nfv = IdSet.cup p.fv q.fv; 
454
	na = acc;
455
	nprod = NLineProd.singleton (src, nnode p, nnode q);
456
457
    }

458
  let nxml lab acc p q = 
459
460
461
    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 
462
    { nempty lab with 
463
	nfv = IdSet.cup p.fv q.fv; 
464
	na = acc;
465
	nxml =  NLineProd.singleton (src, nnode p, nnode q);
466
467
    }
    
468
469
470
471
472
  let nrecord lab acc l p =
    match lab with
      | None -> assert false
      | Some label ->
(*	  Printf.eprintf "[ l = %s; label = %s ]\n" 
473
474
	    (LabelPool.value l)
	    (LabelPool.value label); *)
475
476
477
478
479
480
	  assert (label <= l);
	  if l == label then
	    let src = IdMap.constant SLeft p.fv in
	    { nempty lab with
		nfv = p.fv;
		na = acc;
481
		nrecord = RecLabel(label, 
482
				 NLineProd.singleton (src,nnode p, ncany))}
483
484
485
486
487
488
489
490
	  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;
491
492
493
494
		nrecord = 
		      RecLabel(label,
		        NLineProd.singleton(src,nc Types.Record.any_or_absent, 
 			 nnode p') )}
495
496
497
	  

  let nconstr lab t =
498
499
    let aux l = NLineProd.from_list
		(List.map (fun (t1,t2) -> empty_res, nc t1,nc t2) l) in
500
501
502
503
    let record = 
      match lab with
	| None ->
	    let (x,y) = Types.Record.empty_cases t in
504
	    RecNolabel ((if x then Some empty_res else None), 
505
506
		      (if y then Some empty_res else None))
	| Some l ->
507
	    RecLabel (l,aux (Types.Record.split_normal t l))
508
509
    in	      
    { nempty lab with
510
	na = t;
511
	nbasic = NLineBasic.singleton (empty_res, Types.cap t any_basic);
512
513
514
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
515
516
    }

517
  let nconstant lab x c = 
518
519
520
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
521
      na = Types.any;
522
523
524
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
525
      nrecord = match lab with
526
	| None -> RecNolabel (Some l, Some l)
527
	| Some lab -> 
528
529
530
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
				 ncany))
531
532
    }

533
  let ncapture lab x = 
534
535
536
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
537
      na = Types.any;
538
539
540
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
541
      nrecord = match lab with
542
	| None -> RecNolabel (Some l, Some l)
543
	| Some lab -> 
544
545
546
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
			         ncany))
547
548
    }

549
  let rec nnormal lab (acc,fv,d) =
550
    if Types.is_empty acc 
551
    then nempty lab
552
    else match d with
553
554
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
555
      | Cup ((acc1,_,_) as p,q) -> 
556
557
558
559
560
561
562
563
564
565
566
567
568
	  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 
569
    then LabelPool.dummy_max
570
571
572
573
574
575
    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
576
      | _ -> LabelPool.dummy_max
577

578
579
580
   
  let remove_catchv n =
    let ncv = n.ncatchv in
581
582
583
584
    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
585
    { nfv     = IdSet.diff n.nfv ncv;
586
587
      ncatchv = n.ncatchv;
      na      = n.na;
588
589
590
      nbasic  = nlinesbasic n.nbasic;
      nprod   = nlinesprod n.nprod;
      nxml    = nlinesprod n.nxml;
591
      nrecord = (match n.nrecord with
592
		   | RecNolabel (x,y) ->
593
594
595
596
597
598
		       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
599
		       RecNolabel (x,y)
600
		   | RecLabel (lab,l) -> RecLabel (lab, nlinesprod l))
601
602
    }

603
  let normal l t pl =
604
    remove_catchv
605
606
607
608
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
609
end
610
611


612
613
module Compile = 
struct
614
  type actions =
615
616
    | AIgnore of result
    | AKind of actions_kind
617
  and actions_kind = {
618
    basic: (Types.descr * result) list;
619
620
    atoms: result Atoms.map;
    chars: result Chars.map;
621
    prod: result dispatch dispatch;
622
    xml: result dispatch dispatch;
623
624
625
    record: record option;
  }
  and record = 
626
    | RecLabel of label * result dispatch dispatch
627
    | RecNolabel of result option * result option
628
      
629
  and 'a dispatch =
630
631
632
633
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
634
635

  and result = int * source array
636
  and source = 
637
638
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
639
640
641
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
642
      (int * int id_map) list
643
644

  and interface =
645
646
    [ `Result of int
    | `Switch of interface * interface
647
648
649
650
651
652
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
653
    label : label option;
654
655
    interface : interface;
    codes : return_code array;
656
657
    mutable actions : actions option;
    mutable printed : bool
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
  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


684
685
  let array_for_all f a =
    let rec aux f a i =
686
      if i == Array.length a then true
687
688
689
690
691
692
      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 =
693
      if i == Array.length a then true
694
695
696
697
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

698
  let combine_kind basic prod xml record =
699
700
701
702
703
704
705
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
706
707
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
708
	| _ -> raise Exit in
709
      let rs = match xml with
710
711
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
712
	| _ -> raise Exit in
713
714
      let rs = match record with
	| None -> rs
715
716
	| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
	| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
717
718
	| _ -> raise Exit in
      match rs with
719
	| ((_, ret) as r) :: rs when 
720
	    List.for_all ( equal_result r ) rs 
721
	    && array_for_all 
722
723
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
724
725
	| _ -> raise Exit
    )
726
727
728
729
730
731
732
733
734
735
736
    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 }
      
737
738
  let combine f (disp,act) =
    if Array.length act == 0 then Impossible
739
    else
740
741
      if (array_for_all (fun (_,ar,_) -> ar == 0) disp.codes) 
	 && (array_for_all ( f act.(0) ) act) then
742
	   Ignore act.(0)
743
      else
744
	Dispatch (disp, act)
745
746
747


  let detect_right_tail_call = function
748
    | Dispatch (disp,branches) 
749
750
751
	when
	  array_for_all_i
	    (fun i (code,ret) ->
752
	       (i == code) && 
753
754
	       (array_for_all_i 
		  (fun pos -> 
755
		     function Right j when pos == j -> true | _ -> false)
756
757
758
		  ret
	       )
	    ) branches
759
	  -> TailCall disp
760
761
762
    | x -> x

  let detect_left_tail_call = function
763
    | Dispatch (disp,branches)
764
765
766
767
	when
	  array_for_all_i
	    (fun i -> 
	       function 
768
		 | Ignore (code,ret) ->
769
		     (i == code) &&
770
771
		     (array_for_all_i 
			(fun pos -> 
772
			   function Left j when pos == j -> true | _ -> false)
773
774
775
776
777
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
778
	 TailCall disp
779
780
    | x -> x
   
781
782
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
783
		 
784
785
786
787
788
789
  module NfMap = Map.Make(
    struct 
      type t = Normal.t
      let compare = Normal.compare_nf
    end)

790
791
  module DispMap = Map.Make(
    struct
792
      type t = Types.descr * Normal.t array
793
794
795
796
797
798
799
800
801
802
803
804

      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)
805
806
    end
  )
807
808

    (* Try with a hash-table ! *)
809
    
810
  let dispatchers = ref DispMap.empty
811
		      
812
  let dispatcher t pl lab : dispatcher =
813
814
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
815
      let nb = ref 0 in
816
817
      let codes = ref [] in
      let rec aux t arity i accu = 
818
819
	if Types.is_empty t then `None
	else
820
	  if i == Array.length pl 
821
	  then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
822
823
	  else
	    let p = pl.(i) in
824
	    let tp = p.Normal.na in
825
	    let v = p.Normal.nfv in
826
(*	    let tp = Types.normalize tp in *)
827
	    let accu' = (i,IdMap.num arity v) :: accu in
828
	    `Switch 
829
	      (
830
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
831
	       aux (Types.diff t tp) arity (i+1) accu
832
833
	      )
      in
834
      let iface = aux t 0 0 [] in
835
836
      let res = { id = !cur_id; 
		  t = t;
837
		  label = lab;
838
		  pl = pl;
839
		  interface = iface;
840
		  codes = Array.of_list (List.rev !codes);
841
		  actions = None; printed = false } in
842
843
844
845
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
846
847
  let find_code d a =
    let rec aux i = function
848
849
      | `Result code -> code
      | `None -> assert false
850
      | `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes
851
      | `Switch (_,no) -> aux (i + 1) no
852
853
854
855
    in
    aux 0 d.interface

  let create_result pl =
856
857
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
858
859
860
861
862
863

  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)
    
864
  let conv_source_basic s = match s with
865
866
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
867
868
    | _ -> assert false

869
  let assoc v l =
870
    try IdMap.assoc v l with Not_found -> -1
871

872
  let conv_source_prod left right v s = match s with
873
874
875
876
877
    | 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)
878
879

  let dispatch_basic disp : (Types.descr * result) list =
880
(* TODO: try other algo, using disp.codes .... *)
881
882
883
884
    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
885
      Array.iteri (fun i -> Normal.NLineBasic.iter (aux i)) pl;
886
      Types.DescrSList.Map.get (Types.DescrSList.Map.from_list (@) !accu) in
887
888

    let t = Types.cap Normal.any_basic disp.t in
889
    let accu = ref [] in
890
    let rec aux (success : (int * Normal.result) list) t l = 
891
892
893
      if Types.non_empty t 
      then match l with
	| [] ->
894
895
896
897
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
898
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
899
900
901
902
	    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
903
    in
904
    aux [] t tests;
905
906
907
    !accu


908
  let get_tests pl f t d post =