patterns.ml 36.1 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.t
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
  | Dummy
26
27
and node = {
  id : int;
28
  mutable descr : descr;
29
  accept : Types.Node.t;
30
  fv : fv
31
32
33
} and descr = Types.t * fv * d


34

35
let id x = x.id
36
let descr x = x.descr
37
38
let fv x = x.fv
let accept x = Types.internalize x.accept
39
40
41

let printed = ref []
let to_print = ref []
42
let rec print ppf (a,_,d) = 
43
  match d with
44
    | Constr t -> Types.Print.print ppf t
45
46
47
48
49
50
51
52
53
    | 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) -> 
54
	Format.fprintf ppf "{ %a =  P%i }" Label.print (LabelPool.value l) n.id;
55
56
	to_print := n :: !to_print
    | Capture x ->
57
	Format.fprintf ppf "%a" U.print (Id.value x)
58
    | Constant (x,c) ->
59
	Format.fprintf ppf "(%a := %a)" U.print (Id.value x) 
60
	  Types.Print.print_const c
61
62
    | Dummy ->
	Format.fprintf ppf "*DUMMY*"
63

64
let dump_print ppf =
65
  while !to_print != [] do
66
67
68
69
70
71
72
73
74
75
76
    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
77
78


79
80
let counter = State.ref "Patterns.counter" 0

81
let dummy = (Types.empty,IdSet.empty,Dummy)
82
83
let make fv =
  incr counter;
84
  { id = !counter; descr = dummy; accept = Types.make (); fv = fv }
85
86

let define x ((accept,fv,_) as d) =
87
  (* assert (x.fv = fv); *)
88
  Types.define x.accept accept;
89
  x.descr <- d
90

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


126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
module Node = struct
  type t = node
  include Custom.Dummy
  let compare n1 n2 = n1.id - n2.id
  let equal n1 n2 = n1.id == n2.id
  let hash n = n.id


  module SMemo = Set.Make(Custom.Int)
  let memo = Serialize.Put.mk_property (fun t -> ref SMemo.empty)
  let rec serialize t n = 
    let l = Serialize.Put.get_property memo t in
    Serialize.Put.int t n.id;
    if not (SMemo.mem n.id !l) then (
      l := SMemo.add n.id !l;
      Types.Node.serialize t n.accept;
      IdSet.serialize t n.fv;
      serialize_descr t n.descr
    )
  and serialize_descr s (_,_,d) =
    serialize_d s d
  and serialize_d s = function
    | Constr t ->
	Serialize.Put.bits 3 s 0;
	Types.serialize s t
    | Cup (p1,p2) ->
	Serialize.Put.bits 3 s 1;
	serialize_descr s p1; 
	serialize_descr s p2
    | Cap (p1,p2) ->
	Serialize.Put.bits 3 s 2;
	serialize_descr s p1; 
	serialize_descr s p2
    | Times (p1,p2) ->
	Serialize.Put.bits 3 s 3;
	serialize s p1;
	serialize s p2
    | Xml (p1,p2) ->
	Serialize.Put.bits 3 s 4;
	serialize s p1;
	serialize s p2
    | Record (l,p) ->
	Serialize.Put.bits 3 s 5;
	LabelPool.serialize s l;
	serialize s p
    | Capture x ->
	Serialize.Put.bits 3 s 6;
	Id.serialize s x
    | Constant (x,c) ->
	Serialize.Put.bits 3 s 7;
	Id.serialize s x;
	Types.Const.serialize s c
    | Dummy -> assert false

  module DMemo = Map.Make(Custom.Int)
  let memo = Serialize.Get.mk_property (fun t -> ref DMemo.empty)
  let rec deserialize t = 
    let l = Serialize.Get.get_property memo t in
    let id = Serialize.Get.int t in
    try DMemo.find id !l
    with Not_found ->
      let accept = Types.Node.deserialize t in
      let fv = IdSet.deserialize t in
      incr counter;
      let n = { id = !counter; descr = dummy; accept = accept; fv = fv } in
      l := DMemo.add id n !l;
      n.descr <- deserialize_descr t;
      n
  and deserialize_descr s =
    match Serialize.Get.bits 3 s with
      | 0 -> constr (Types.deserialize s)
      | 1 ->
	  (* Avoid unnecessary tests *)
	  let (acc1,fv1,_) as x1 = deserialize_descr s in
	  let (acc2,fv2,_) as x2 = deserialize_descr s in
	  (Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
      | 2 ->
	  let (acc1,fv1,_) as x1 = deserialize_descr s in
	  let (acc2,fv2,_) as x2 = deserialize_descr s in
	  (Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2))
      | 3 ->
	  let x = deserialize s in
	  let y = deserialize s in
	  times x y
      | 4 ->
	  let x = deserialize s in
	  let y = deserialize s in
	  xml x y
      | 5 ->
	  let l = LabelPool.deserialize s in
	  let x = deserialize s in
	  record l x
      | 6 -> capture (Id.deserialize s)
      | 7 ->
	  let x = Id.deserialize s in
	  let c = Types.Const.deserialize s in
	  constant x c
      | _ -> assert false


end
227
228
229
230
231


(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
232
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
233
234
let times_res v1 v2 = Types.Positive.times v1 v2

235
(* Try with a hash-table *)
236
module MemoFilter = Map.Make 
237
  (struct 
238
     type t = Types.t * node 
239
240
     let compare (t1,n1) (t2,n2) = 
       if n1.id < n2.id then -1 else if n1.id > n2.id then 1 else
241
       Types.compare t1 t2
242
   end)
243
244
245

let memo_filter = ref MemoFilter.empty

246
let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
247
(* TODO: avoid is_empty t when t is not changing (Cap) *)
248
249
250
251
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
252
      | Constr _ -> IdMap.empty
253
      | Cup ((a,_,_) as d1,d2) ->
254
	  IdMap.merge cup_res
255
256
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
257
      | Cap (d1,d2) ->
258
	  IdMap.merge cup_res (filter_descr t d1) (filter_descr t d2)
259
260
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
261
262
263
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
264
	  IdMap.singleton c (Types.Positive.ty t)
265
      | Constant (c, cst) ->
266
	  IdMap.singleton c (Types.Positive.ty (Types.constant cst))
267
      | Dummy -> assert false
268

269
270
271
272
and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
273
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
274
       in
275
       IdMap.merge cup_res accu term
276
277
278
279
280
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


281
and filter_node t p : Types.Positive.v id_map =
282
283
284
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
    let (_,fv,_) as d = descr p in
285
    let res = IdMap.map_from_slist (fun _ -> Types.Positive.forward ()) fv in
286
287
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
288
    IdMap.collide Types.Positive.define res r;
289
290
291
292
293
    r

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
294
  IdMap.get (IdMap.map Types.Positive.solve r)
295
296


297
298
(* Normal forms for patterns and compilation *)

299
300
let min (a:int) (b:int) = if a < b then a else b

301
302
303
let any_basic = Types.Record.or_absent Types.non_constructed


304
module Normal = struct
305

306
  type source = 
307
308
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
309
  type result = source id_map
310

311
312
313
314
315
316
317
  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
318
      | SConst c1, SConst c2 -> Types.Const.compare c1 c2
319
320
321
322
323
324

  let hash_source = function
    | SCatch -> 1
    | SLeft -> 2
    | SRight -> 3
    | SRecompose -> 4
325
    | SConst c -> Types.Const.hash c
326
327
328
329
330
331
332
333
334
    
  let compare_result r1 r2 =
    IdMap.compare compare_source r1 r2

  let hash_result r =
    IdMap.hash hash_source r


  module NodeSet = 
335
336
    SortedList.Make(Node)

337

338
  type nnf = NodeSet.t * Types.t (* pl,t;   t <= \accept{pl} *)
339
340
341

  let compare_nnf (l1,t1) (l2,t2) =
    let c = NodeSet.compare l1 l2 in if c <> 0 then c
342
    else Types.compare t1 t2
343
344

  let hash_nnf (l,t) =
345
    (NodeSet.hash l) + 17 * (Types.hash t)
346
347
348
349

  module NLineBasic = 
    SortedList.Make(
      struct
350
351
	include Custom.Dummy
	type t = result * Types.t
352
353
	let compare (r1,t1) (r2,t2) =
	  let c = compare_result r1 r2 in if c <> 0 then c
354
	  else Types.compare t1 t2
355
	let equal x y = compare x y == 0
356
	let hash (r,t) = hash_result r + 17 * Types.hash t
357
358
359
360
361
362
      end
    )

  module NLineProd = 
    SortedList.Make(
      struct
363
364
	include Custom.Dummy
	type t = result * nnf * nnf
365
366
367
368
	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
369
	let equal x y = compare x y == 0
370
371
372
373
374
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

375
  type record =
376
    | RecNolabel of result option * result option
377
    | RecLabel of label * NLineProd.t
378
  type t = {
379
    nfv    : fv;
380
    ncatchv: fv;
381
382
383
384
    na     : Types.t;
    nbasic : NLineBasic.t;
    nprod  : NLineProd.t;
    nxml   : NLineProd.t;
385
    nrecord: record
386
387
  }

388
389
390
391
392
393
  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
394
      else let c = Types.compare t1.na t2.na in if c <> 0 then c
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
      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
416

417
  let fus = IdMap.union_disj
418

419
420
421
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
422
423
424
      nbasic = NLineBasic.empty; 
      nprod = NLineProd.empty; 
      nxml = NLineProd.empty;
425
      nrecord = (match lab with 
426
		   | Some l -> RecLabel (l,NLineProd.empty)
427
		   | None -> RecNolabel (None,None))
428
    }
429
  let dummy = nempty None
430
431
432
433
434
435


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
436
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
437
      na      = Types.cup nf1.na nf2.na;
438
439
440
      nbasic  = NLineBasic.cup nf1.nbasic nf2.nbasic;
      nprod   = NLineProd.cup nf1.nprod nf2.nprod;
      nxml    = NLineProd.cup nf1.nxml nf2.nxml;
441
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
442
		   | RecLabel (l1,r1), RecLabel (l2,r2) -> 
443
		       (* assert (l1 = l2); *) RecLabel (l1, NLineProd.cup r1 r2)
444
		   | RecNolabel (x1,y1), RecNolabel (x2,y2) -> 
445
446
		       RecNolabel((if x1 == None then x2 else x1),
				(if y1 == None then y2 else y1))
447
		   | _ -> assert false)
448
449
450
    }

  let double_fold f l1 l2 =
451
452
453
454
455
456
    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)
457
458
	 
  let ncap nf1 nf2 =
459
    let prod accu (res1,(pl1,t1),(ql1,s1)) (res2,(pl2,t2),(ql2,s2)) =
460
461
462
463
      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
464
465
	  (fus res1 res2, (NodeSet.cup pl1 pl2,t),(NodeSet.cup ql1 ql2,s)) 
	  :: accu
466
467
468
469
470
471
    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
472
    let record r1 r2 = match r1,r2 with
473
      | RecLabel (l1,r1), RecLabel (l2,r2) ->
474
	  (* assert (l1 = l2); *)
475
	  RecLabel(l1, NLineProd.from_list (double_fold_prod prod r1 r2))
476
      | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
477
478
479
480
481
482
	  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
483
	  RecNolabel (x,y)
484
      | _ -> assert false
485
    in
486
487
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
488
      na = Types.cap nf1.na nf2.na;
489
490
491
492
493
494
      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;
495
496
    }

497
498
499
500
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

501
  let empty_res = IdMap.empty
502

503
  let ntimes lab acc p q = 
504
505
506
    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 
507
    { nempty lab with 
508
	nfv = IdSet.cup p.fv q.fv; 
509
	na = acc;
510
	nprod = NLineProd.singleton (src, nnode p, nnode q);
511
512
    }

513
  let nxml lab acc p q = 
514
515
516
    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 
517
    { nempty lab with 
518
	nfv = IdSet.cup p.fv q.fv; 
519
	na = acc;
520
	nxml =  NLineProd.singleton (src, nnode p, nnode q);
521
522
    }
    
523
524
525
526
527
528
529
530
531
532
  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;
533
		nrecord = RecLabel(label, 
534
				 NLineProd.singleton (src,nnode p, ncany))}
535
536
537
538
539
540
541
542
	  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;
543
544
545
546
		nrecord = 
		      RecLabel(label,
		        NLineProd.singleton(src,nc Types.Record.any_or_absent, 
 			 nnode p') )}
547
548
549
	  

  let nconstr lab t =
550
551
    let aux l = NLineProd.from_list
		(List.map (fun (t1,t2) -> empty_res, nc t1,nc t2) l) in
552
553
554
555
    let record = 
      match lab with
	| None ->
	    let (x,y) = Types.Record.empty_cases t in
556
	    RecNolabel ((if x then Some empty_res else None), 
557
558
		      (if y then Some empty_res else None))
	| Some l ->
559
	    RecLabel (l,aux (Types.Record.split_normal t l))
560
561
    in	      
    { nempty lab with
562
	na = t;
563
	nbasic = NLineBasic.singleton (empty_res, Types.cap t any_basic);
564
565
566
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
567
568
    }

569
  let nconstant lab x c = 
570
571
572
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
573
      na = Types.any;
574
575
576
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
577
      nrecord = match lab with
578
	| None -> RecNolabel (Some l, Some l)
579
	| Some lab -> 
580
581
582
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
				 ncany))
583
584
    }

585
  let ncapture lab x = 
586
587
588
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
589
      na = Types.any;
590
591
592
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
593
      nrecord = match lab with
594
	| None -> RecNolabel (Some l, Some l)
595
	| Some lab -> 
596
597
598
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
			         ncany))
599
600
    }

601
  let rec nnormal lab (acc,fv,d) =
602
    if Types.is_empty acc 
603
    then nempty lab
604
    else match d with
605
606
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
607
      | Cup ((acc1,_,_) as p,q) -> 
608
609
610
611
612
613
614
	  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
615
      | Dummy -> assert false
616
617
618
619
620
621

(*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 
622
    then LabelPool.dummy_max
623
624
625
626
627
628
    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
629
      | _ -> LabelPool.dummy_max
630

631
632
633
   
  let remove_catchv n =
    let ncv = n.ncatchv in
634
635
636
637
    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
638
    { nfv     = IdSet.diff n.nfv ncv;
639
640
      ncatchv = n.ncatchv;
      na      = n.na;
641
642
643
      nbasic  = nlinesbasic n.nbasic;
      nprod   = nlinesprod n.nprod;
      nxml    = nlinesprod n.nxml;
644
      nrecord = (match n.nrecord with
645
		   | RecNolabel (x,y) ->
646
647
648
649
650
651
		       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
652
		       RecNolabel (x,y)
653
		   | RecLabel (lab,l) -> RecLabel (lab, nlinesprod l))
654
655
    }

656
  let normal l t pl =
657
    remove_catchv
658
659
660
661
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
662
end
663
664


665
666
module Compile = 
struct
667
  type actions =
668
669
    | AIgnore of result
    | AKind of actions_kind
670
  and actions_kind = {
671
    basic: (Types.t * result) list;
672
673
    atoms: result Atoms.map;
    chars: result Chars.map;
674
    prod: result dispatch dispatch;
675
    xml: result dispatch dispatch;
676
677
678
    record: record option;
  }
  and record = 
679
    | RecLabel of label * result dispatch dispatch
680
    | RecNolabel of result option * result option
681
      
682
  and 'a dispatch =
683
684
685
686
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
687
688

  and result = int * source array
689
  and source = 
690
691
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
692
693
      
  and return_code = 
694
      Types.t * int *   (* accepted type, arity *)
695
      (int * int id_map) list
696
697

  and interface =
698
699
    [ `Result of int
    | `Switch of interface * interface
700
701
702
703
    | `None ]

  and dispatcher = {
    id : int;
704
    t  : Types.t;
705
    pl : Normal.t array;
706
    label : label option;
707
708
    interface : interface;
    codes : return_code array;
709
710
    mutable actions : actions option;
    mutable printed : bool
711
  }
712

713
714
715
716
717
718
719
  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
720
      | Const x, Const y -> Types.Const.equal x y 
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
      | 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


737
738
  let array_for_all f a =
    let rec aux f a i =
739
      if i == Array.length a then true
740
741
742
743
744
745
      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 =
746
      if i == Array.length a then true
747
748
749
750
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

751
  let combine_kind basic prod xml record =
752
753
754
755
756
757
758
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
759
760
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
761
	| _ -> raise Exit in
762
      let rs = match xml with
763
764
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
765
	| _ -> raise Exit in
766
767
      let rs = match record with
	| None -> rs
768
769
	| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
	| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
770
771
	| _ -> raise Exit in
      match rs with
772
	| ((_, ret) as r) :: rs when 
773
	    List.for_all ( equal_result r ) rs 
774
	    && array_for_all 
775
776
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
777
778
	| _ -> raise Exit
    )
779
780
781
782
783
784
785
786
787
788
789
    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 }
      
790
791
  let combine f (disp,act) =
    if Array.length act == 0 then Impossible
792
    else
793
794
      if (array_for_all (fun (_,ar,_) -> ar == 0) disp.codes) 
	 && (array_for_all ( f act.(0) ) act) then
795
	   Ignore act.(0)
796
      else
797
	Dispatch (disp, act)
798
799
800


  let detect_right_tail_call = function
801
    | Dispatch (disp,branches) 
802
803
804
	when
	  array_for_all_i
	    (fun i (code,ret) ->
805
	       (i == code) && 
806
807
	       (array_for_all_i 
		  (fun pos -> 
808
		     function Right j when pos == j -> true | _ -> false)
809
810
811
		  ret
	       )
	    ) branches
812
	  -> TailCall disp
813
814
815
    | x -> x

  let detect_left_tail_call = function
816
    | Dispatch (disp,branches)
817
818
819
820
	when
	  array_for_all_i
	    (fun i -> 
	       function 
821
		 | Ignore (code,ret) ->
822
		     (i == code) &&
823
824
		     (array_for_all_i 
			(fun pos -> 
825
			   function Left j when pos == j -> true | _ -> false)
826
827
828
829
830
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
831
	 TailCall disp
832
833
    | x -> x
   
834
835
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
836
		 
837
838
839
840
841
842
  module NfMap = Map.Make(
    struct 
      type t = Normal.t
      let compare = Normal.compare_nf
    end)

843
844
  module DispMap = Map.Make(
    struct
845
      type t = Types.t * Normal.t array
846
847
848
849
850
851
852
853

      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) =
854
	let c = Types.compare t1 t2 in if c <> 0 then c 
855
856
857
	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)
858
859
    end
  )
860
861

    (* Try with a hash-table ! *)
862
    
863
  let dispatchers = ref DispMap.empty
864
		      
865
  let dispatcher t pl lab : dispatcher =
866
867
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
868
      let nb = ref 0 in
869
870
      let codes = ref [] in
      let rec aux t arity i accu = 
871
872
	if Types.is_empty t then `None
	else
873
	  if i == Array.length pl 
874
	  then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
875
876
	  else
	    let p = pl.(i) in
877
	    let tp = p.Normal.na in
878
	    let v = p.Normal.nfv in
879
(*	    let tp = Types.normalize tp in *)
880
	    let accu' = (i,IdMap.num arity v) :: accu in
881
	    `Switch 
882
	      (
883
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
884
	       aux (Types.diff t tp) arity (i+1) accu
885
886
	      )
      in
887
      let iface = aux t 0 0 [] in
888
889
      let res = { id = !cur_id; 
		  t = t;
890
		  label = lab;
891
		  pl = pl;
892
		  interface = iface;
893
		  codes = Array.of_list (List.rev !codes);
894
		  actions = None; printed = false } in
895
896
897
898
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
899
900
  let find_code d a =
    let rec aux i = function
901
902
      | `Result code -> code
      | `None -> assert false
903
      | `Switch (yes,_) when a.(i) != None -> aux (i + 1) yes
904
      | `Switch (_,no) -> aux (i + 1) no
905
906
907
908
    in
    aux 0 d.interface

  let create_result pl =
909
910
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
911
912
913
914
915
916

  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)