patterns.ml 34.4 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
27
28
29
30
31
and node = {
  id : int;
  mutable descr : descr option;
  accept : Types.node;
  fv : fv
} and descr = Types.descr * fv * d

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 "{ %s =  P%i }" (LabelPool.value l) n.id;
52
53
	to_print := n :: !to_print
    | Capture x ->
54
	Format.fprintf ppf "%s" (Id.value x)
55
    | Constant (x,c) ->
56
57
	Format.fprintf ppf "(%s := %a)" (Id.value x) 
	  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
83
84
  Types.define x.accept accept;
  x.descr <- Some d

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 " ^ (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 " ^ (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
176
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
    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
190
(* Normal forms for patterns and compilation *)

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

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

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

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

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

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


234
  type source = 
235
236
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
237
  type result = source id_map
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
  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
288
	let equal x y = compare x y == 0
289
290
291
292
293
294
295
296
297
298
299
300
	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
301
	let equal x y = compare x y == 0
302
303
304
305
306
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

307
  type record =
308
    | RecNolabel of result option * result option
309
    | RecLabel of label * unit NLineProd.t
310
  type t = {
311
    nfv    : fv;
312
    ncatchv: fv;
313
    na     : Types.descr;
314
315
316
    nbasic : unit NLineBasic.t;
    nprod  : unit NLineProd.t;
    nxml   : unit NLineProd.t;
317
    nrecord: record
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
343
344
345
346
347
  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
348

349
  let fus = IdMap.union_disj
350

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


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

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

429
430
431
432
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

433
  let empty_res = IdMap.empty
434

435
  let ntimes lab acc p q = 
436
437
438
    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 
439
    { nempty lab with 
440
	nfv = IdSet.cup p.fv q.fv; 
441
	na = acc;
442
	nprod = NLineProd.singleton (src, nnode p, nnode q);
443
444
    }

445
  let nxml lab acc p q = 
446
447
448
    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 
449
    { nempty lab with 
450
	nfv = IdSet.cup p.fv q.fv; 
451
	na = acc;
452
	nxml =  NLineProd.singleton (src, nnode p, nnode q);
453
454
    }
    
455
456
457
458
459
460
461
462
463
464
  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;
465
		nrecord = RecLabel(label, 
466
				 NLineProd.singleton (src,nnode p, ncany))}
467
468
469
470
471
472
473
474
	  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;
475
476
477
478
		nrecord = 
		      RecLabel(label,
		        NLineProd.singleton(src,nc Types.Record.any_or_absent, 
 			 nnode p') )}
479
480
481
	  

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

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

517
  let ncapture lab x = 
518
519
520
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
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 rec nnormal lab (acc,fv,d) =
534
    if Types.is_empty acc 
535
    then nempty lab
536
    else match d with
537
538
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
539
      | Cup ((acc1,_,_) as p,q) -> 
540
541
542
543
544
545
546
547
548
549
550
551
552
	  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 
553
    then LabelPool.dummy_max
554
555
556
557
558
559
    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
560
      | _ -> LabelPool.dummy_max
561

562
563
564
   
  let remove_catchv n =
    let ncv = n.ncatchv in
565
566
567
568
    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
569
    { nfv     = IdSet.diff n.nfv ncv;
570
571
      ncatchv = n.ncatchv;
      na      = n.na;
572
573
574
      nbasic  = nlinesbasic n.nbasic;
      nprod   = nlinesprod n.nprod;
      nxml    = nlinesprod n.nxml;
575
      nrecord = (match n.nrecord with
576
		   | RecNolabel (x,y) ->
577
578
579
580
581
582
		       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
583
		       RecNolabel (x,y)
584
		   | RecLabel (lab,l) -> RecLabel (lab, nlinesprod l))
585
586
    }

587
  let normal l t pl =
588
    remove_catchv
589
590
591
592
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
593
end
594
595


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

  and result = int * source array
620
  and source = 
621
622
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
623
624
625
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
626
      (int * int id_map) list
627
628

  and interface =
629
630
    [ `Result of int
    | `Switch of interface * interface
631
632
633
634
635
636
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
637
    label : label option;
638
639
    interface : interface;
    codes : return_code array;
640
641
    mutable actions : actions option;
    mutable printed : bool
642
  }
643

644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
  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


668
669
  let array_for_all f a =
    let rec aux f a i =
670
      if i == Array.length a then true
671
672
673
674
675
676
      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 =
677
      if i == Array.length a then true
678
679
680
681
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

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


  let detect_right_tail_call = function
732
    | Dispatch (disp,branches) 
733
734
735
	when
	  array_for_all_i
	    (fun i (code,ret) ->
736
	       (i == code) && 
737
738
	       (array_for_all_i 
		  (fun pos -> 
739
		     function Right j when pos == j -> true | _ -> false)
740
741
742
		  ret
	       )
	    ) branches
743
	  -> TailCall disp
744
745
746
    | x -> x

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

774
775
  module DispMap = Map.Make(
    struct
776
      type t = Types.descr * Normal.t array
777
778
779
780
781
782
783
784
785
786
787
788

      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)
789
790
    end
  )
791
792

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

  let create_result pl =
840
841
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
842
843
844
845
846
847

  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)
    
848
  let conv_source_basic s = match s with
849
850
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
851
852
    | _ -> assert false

853
  let assoc v l =
854
    try IdMap.assoc v l with Not_found -> -1
855

856
  let conv_source_prod left right v s = match s with
857
858
859
860
861
    | 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)
862
863

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

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


892
  let get_tests pl f t d post =
893
894
    let accu = ref [] in
    let aux i x = 
895
      let (pl,ty), info = f x in
896
      let pl = Normal.NodeSet.get pl in
897
      accu := (ty,pl,i,info) :: !accu in
898
    Array.iteri (fun i -> List.iter (aux i)) pl;
899

900
901
902
903
904
905
906
    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
907
	) LabelPool.dummy_max !accu in
908
    let lab = if lab == LabelPool.dummy_max then None else Some lab in
909

Pietro Abate's avatar