patterns.ml 33.3 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
and node = {
  id : int;
17
18
  mutable descr : descr option;
  accept : Types.node;
19
  fv : fv
20
} and descr = Types.descr * fv * d
21

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

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

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

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
210
  val compare_nf: t -> t -> int

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


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

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
  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
    )

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

351
  let fus = IdMap.union_disj
352

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


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

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

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

434
  let empty_res = IdMap.empty
435

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

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

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

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

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

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

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

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


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

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

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

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

  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

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


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

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

      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)
763
764
    end
  )
765
766

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

  let create_result pl =
814
815
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
816
817
818
819
820
821

  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)
    
822
  let conv_source_basic s = match s with
823
824
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
825
826
    | _ -> assert false

827
  let assoc v l =
828
    try IdMap.assoc v l with Not_found -> -1
829

830
  let conv_source_prod left right v s = match s with
831
832
833
834
835
    | 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)
836
837

  let dispatch_basic disp : (Types.descr * result) list =
838
(* TODO: try other algo, using disp.codes .... *)
839
840
841
842
    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
843
844
      Array.iteri (fun i -> Normal.NLineBasic.iter (aux i)) pl;
       Types.DescrSList.Map.get (Types.DescrSList.Map.from_list (@) !accu) in
845
846

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


866
  let get_tests pl f t d post =
867
868
    let accu = ref [] in
    let aux i x = 
869
      let (pl,ty), info = f x in
870
      let pl = Normal.NodeSet.get pl in
871
      accu := (ty,pl,i,info) :: !accu in
872
    Array.iteri (fun i -> List.iter (aux i)) pl;
873

874
875
876
877
878
879
880
    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
881
882
	) LabelPool.dummy_max !accu in
    let lab = if lab= LabelPool.dummy_max then None else Some lab in
883
884
885
886
887
888

    let accu = 
      List.map (fun (ty,pl,i,info) -> 
		  let p = Normal.normal lab ty pl in
		  (p,[i, p.Normal.ncatchv, info])) 
	!accu in
889
    (* eliminate this generic comparison *)
890
    let sorted = Array.of_list (SortedMap.from_list SortedList.cup accu) in
891
    let infos = Array.map snd sorted in
892
    let disp = dispatcher t (Array.map fst sorted) lab in
893
    let result (t,_,m) =
894
      let selected = Array.create (Array.length pl) [] in
895
      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
896
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
897
      d t selected
898
    in
899
    let res = Array.map result disp.codes in
900
901
    post (disp,res)

902

903
904
905
906
  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
907
	   let p' = (Normal.NodeSet.singleton p,t) in
908
909
	   let t' = Types.diff t (Types.descr (accept p)) in
	   (t', (p',e) :: brs)
910
	) (t,[]) brs in
Pietro Abate's avatar