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

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

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

28
29
30
31
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
32
33
34

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

56
57
58
59
60
61
62
63
64
65
66
67
68
let dump_print ppf =
  while !to_print <> [] do
    let p = List.hd !to_print in
    to_print := List.tl !to_print;
    if not (List.mem p.id !printed) then
      ( printed := p.id :: !printed;
	Format.fprintf ppf "P%i:=%a\n" p.id print (descr p)
      )
  done

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


71
72
73
74
75
let counter = State.ref "Patterns.counter" 0

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

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

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




(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
122
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
123
124
let times_res v1 v2 = Types.Positive.times v1 v2

125
(* Try with a hash-table *)
126
module MemoFilter = Map.Make 
127
128
129
130
131
132
  (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)
133
134
135

let memo_filter = ref MemoFilter.empty

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

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


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

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
183
  IdMap.get (IdMap.map Types.Positive.solve r)
184
185


186
187
(* Normal forms for patterns and compilation *)

188
189
let min (a:int) (b:int) = if a < b then a else b

190
191
module Normal : sig 
  type source = 
192
193
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
194
  type result = source id_map
195

196
197
198
199
200
201
  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

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

215
  val dummy: t
216
217
  val compare_nf: t -> t -> int

218
  val any_basic: Types.descr
219
220
  val first_label: descr -> label
  val normal: label option -> Types.descr -> node list -> t
221
end = 
222
struct
223
224
225
226
227
228
  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]))
229
230


231
  type source = 
232
233
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
234
  type result = source id_map
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
283
284
285
286
287
288
289
290
291
292
293
294
295
296
  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
297
	let equal x y = compare x y == 0
298
299
300
301
302
303
304
305
306
307
308
309
	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
310
	let equal x y = compare x y == 0
311
312
313
314
315
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

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

358
  let fus = IdMap.union_disj
359

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


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

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

438
439
440
441
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

442
  let empty_res = IdMap.empty
443

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

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

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

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

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

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

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

599
  let normal l t pl =
600
    remove_catchv
601
602
603
604
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
605
end
606
607


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

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

  and interface =
641
642
    [ `Result of int
    | `Switch of interface * interface
643
644
645
646
647
648
    | `None ]

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


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

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


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

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

786
787
  module DispMap = Map.Make(
    struct
788
      type t = Types.descr * Normal.t array
789
790
791
792
793
794
795
796
797
798
799
800

      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)
801
802
    end
  )
803
804

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

  let create_result pl =
852
853
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
854
855
856
857
858
859

  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)
    
860
  let conv_source_basic s = match s with
861
862
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
863
864
    | _ -> assert false

865
  let assoc v l =
866
    try IdMap.assoc v l with Not_found -> -1
867

868
  let conv_source_prod left right v s = match s with
869
870
871
872
873
    | 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)
874
875

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

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


904
  let get_tests pl f t d post =
905
906
    let accu = ref [] in
    let aux i x = 
907
      let (pl,ty), info = f x in
908
      let pl = Normal.NodeSet.get pl in
909
      accu := (ty,pl,i,info) :: !accu in
910
    Array.iteri (fun i -> List.iter (aux i)) pl;
911

912
913
914
915
916
917
918
    let lab =
      List.fold_left 
	(fun l (ty,pl,_,_) ->
	   List.fold_left
	     (fun l p -> min l (Normal.first_label (descr p)))
	     (min l (Types.Record.first_label ty))
	     pl
919
	) LabelPool.dummy_max !accu in
920
    let lab = if lab == LabelPool.dummy_max then None else Some lab in
921

922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943

    let pats = ref NfMap.empty in
    let nb_p = ref 0 in
    List.iter
      (fun (ty,pl,i,info) -> 
	 let p = Normal.normal lab ty pl in
	 let x = (i, p.Normal.ncatchv, info) in
	 try 
	   let s = NfMap.find p !pats in
	   s := x :: !s
	 with Not_found ->
	   pats := NfMap.add p (ref [x]) !pats;
	   incr nb_p
      ) !accu;
    let infos = Array.make !nb_p [] in
    let ps = Array.make !nb_p