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

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

22
23
24
25
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
26
27
28

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

50
51
52
53
54
55
56
57
58
59
60
61
62
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
63
64


65
66
67
68
69
let counter = State.ref "Patterns.counter" 0

let make fv =
  incr counter;
  { id = !counter; descr = None; accept = Types.make (); fv = fv }
70
71
72
73
74
75

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

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




(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
116
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
117
118
let times_res v1 v2 = Types.Positive.times v1 v2

119
(* Try with a hash-table *)
120
module MemoFilter = Map.Make 
121
122
123
124
125
126
  (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)
127
128
129

let memo_filter = ref MemoFilter.empty

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

152
153
154
155
and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
156
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
157
       in
158
       IdMap.merge cup_res accu term
159
160
161
162
163
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


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

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
177
  IdMap.get (IdMap.map Types.Positive.solve r)
178
179


180
181
(* Normal forms for patterns and compilation *)

182
183
let min (a:int) (b:int) = if a < b then a else b

184
185
module Normal : sig 
  type source = 
186
187
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
188
  type result = source id_map
189

190
191
192
193
194
195
  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

196
  type record =
197
    | RecNolabel of result option * result option
198
    | RecLabel of label * unit NLineProd.t
199
200
201
202
  type t = {
    nfv    : fv;
    ncatchv: fv;
    na     : Types.descr;
203
204
205
    nbasic : unit NLineBasic.t;
    nprod  : unit NLineProd.t;
    nxml   : unit NLineProd.t;
206
    nrecord: record;
207
208
  }

209
  val dummy: t
210
211
  val compare_nf: t -> t -> int

212
  val any_basic: Types.descr
213
214
  val first_label: descr -> label
  val normal: label option -> Types.descr -> node list -> t
215
end = 
216
struct
217
218
219
220
221
222
  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]))
223
224


225
  type source = 
226
227
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
228
  type result = source id_map
229

230
231
232
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
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
  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
	let equal x y = compare x y = 0
	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
	let equal x y = compare x y = 0
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

310
  type record =
311
    | RecNolabel of result option * result option
312
    | RecLabel of label * unit NLineProd.t
313
  type t = {
314
    nfv    : fv;
315
    ncatchv: fv;
316
    na     : Types.descr;
317
318
319
    nbasic : unit NLineBasic.t;
    nprod  : unit NLineProd.t;
    nxml   : unit NLineProd.t;
320
    nrecord: record
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
348
349
350
  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
351

352
  let fus = IdMap.union_disj
353

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


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

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

432
433
434
435
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

436
  let empty_res = IdMap.empty
437

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

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

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

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

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

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

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

593
  let normal l t pl =
594
    remove_catchv
595
596
597
598
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
599
end
600
601


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

  and result = int * source array
626
  and source = 
627
628
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
629
630
631
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
632
      (int * int id_map) list
633
634

  and interface =
635
636
    [ `Result of int
    | `Switch of interface * interface
637
638
639
640
641
642
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
643
    label : label option;
644
645
    interface : interface;
    codes : return_code array;
646
647
    mutable actions : actions option;
    mutable printed : bool
648
  }
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663

  let array_for_all f a =
    let rec aux f a i =
      if i = Array.length a then true
      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 =
      if i = Array.length a then true
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

664
  let combine_kind basic prod xml record =
665
666
667
668
669
670
671
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
672
673
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
674
	| _ -> raise Exit in
675
      let rs = match xml with
676
677
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
678
	| _ -> raise Exit in
679
680
      let rs = match record with
	| None -> rs
681
682
	| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
	| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
683
684
	| _ -> raise Exit in
      match rs with
685
686
687
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
688
689
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
690
691
	| _ -> raise Exit
    )
692
693
694
695
696
697
698
699
700
701
702
    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 }
      
703
  let combine (disp,act) =
704
    if Array.length act = 0 then Impossible
705
706
707
    else
      if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes) 
	 && (array_for_all ( (=) act.(0) ) act) then
708
	   Ignore act.(0)
709
      else
710
	Dispatch (disp, act)
711
712
713


  let detect_right_tail_call = function
714
    | Dispatch (disp,branches) 
715
716
717
718
719
720
	when
	  array_for_all_i
	    (fun i (code,ret) ->
	       (i = code) && 
	       (array_for_all_i 
		  (fun pos -> 
721
		     function Right j when pos = j -> true | _ -> false)
722
723
724
		  ret
	       )
	    ) branches
725
	  -> TailCall disp
726
727
728
    | x -> x

  let detect_left_tail_call = function
729
    | Dispatch (disp,branches)
730
731
732
733
	when
	  array_for_all_i
	    (fun i -> 
	       function 
734
		 | Ignore (code,ret) ->
735
736
737
		     (i = code) &&
		     (array_for_all_i 
			(fun pos -> 
738
			   function Left j when pos = j -> true | _ -> false)
739
740
741
742
743
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
744
	 TailCall disp
745
746
    | x -> x
   
747
748
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
749
		 
750
751
752
753
754
755
  module NfMap = Map.Make(
    struct 
      type t = Normal.t
      let compare = Normal.compare_nf
    end)

756
757
  module DispMap = Map.Make(
    struct
758
      type t = Types.descr * Normal.t array
759
760
761
762
763
764
765
766
767
768
769
770

      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)
771
772
    end
  )
773
774

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

  let create_result pl =
822
823
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
824
825
826
827
828
829

  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)
    
830
  let conv_source_basic s = match s with
831
832
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
833
834
    | _ -> assert false

835
  let assoc v l =
836
    try IdMap.assoc v l with Not_found -> -1
837

838
  let conv_source_prod left right v s = match s with
839
840
841
842
843
    | 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)
844
845

  let dispatch_basic disp : (Types.descr * result) list =
846
(* TODO: try other algo, using disp.codes .... *)
847
848
849
850
    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
851
852
      Array.iteri (fun i -> Normal.NLineBasic.iter (aux i)) pl;
       Types.DescrSList.Map.get (Types.DescrSList.Map.from_list (@) !accu) in
853
854

    let t = Types.cap Normal.any_basic disp.t in
855
    let accu = ref [] in
856
    let rec aux (success : (int * Normal.result) list) t l = 
857
858
859
      if Types.non_empty t 
      then match l with
	| [] ->
860
861
862
863
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
864
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
865
866
867
868
	    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
869
    in
870
    aux [] t tests;
871
872
873
    !accu


874
  let get_tests pl f t d post =
875
876
    let accu = ref [] in
    let aux i x = 
877
      let (pl,ty), info = f x in
878
      let pl = Normal.NodeSet.get pl in
879
      accu := (ty,pl,i,info) :: !accu in
880
    Array.iteri (fun i -> List.iter (aux i)) pl;
881

882
883
884
885
886
887
888
    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
889
890
	) LabelPool.dummy_max !accu in
    let lab = if lab= LabelPool.dummy_max then None else Some lab in
891

892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916

    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 Normal.dummy in
    let count = ref 0 in
    NfMap.iter (fun p l ->
		  let i = !count in
		  infos.(i) <- !l;
		  ps.(i) <- p;
		  count := succ i) !pats;
    assert( !nb_p = !count );
    let disp = dispatcher t ps lab in

917
    let result (t,_,m) =
918
      let selected = Array.create (Array.length pl) [] in
919
      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
920
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
921
      d t selected
922
    in
923
    let res = Array.map result disp.codes in
924
925
    post (disp,res)

926

927
928
929
930
  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
931
	   let p' = (Normal.NodeSet.singleton p,t) in
932
933
	   let t' = Types.diff t (Types.descr (accept p)) in
	   (t', (p',e) :: brs)
934
	) (t,[]) brs in
935
	
936
937
938
    let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
    get_tests 
      pl 
939
      (fun x -> x)
940
      t
941
      (fun _ pl ->
942
943
	 let r = ref None in
	 let aux = function 
944
	   | [(res,catchv,e)] -> assert (!r = None);