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

4
5
6
7
8
let print_lab ppf l = 
  if (l == LabelPool.dummy_max) 
  then Format.fprintf ppf "<dummy_max>"
  else Label.print ppf (LabelPool.value l)

9
10
11
(*
To be sure not to use generic comparison ...
*)
12
13
14
15
16
17
let (=) : int -> int -> bool = (==)
let (<) : int -> int -> bool = (<)
let (<=) : int -> int -> bool = (<=)
let (<>) : int -> int -> bool = (<>)
let compare = 1

18

19
(* Syntactic algebra *)
20
(* Constraint: any node except Constr has fv<>[] ... *)
21
type d =
22
  | Constr of Types.t
23
  | Cup of descr * descr
24
  | Cap of descr * descr
25
  | Times of node * node
26
  | Xml of node * node
27
  | Record of label * node
28
29
  | Capture of id
  | Constant of id * Types.const
30
  | Dummy
31
32
and node = {
  id : int;
33
  mutable descr : descr;
34
  accept : Types.Node.t;
35
  fv : fv
36
37
38
} and descr = Types.t * fv * d


39

40
let id x = x.id
41
let descr x = x.descr
42
43
let fv x = x.fv
let accept x = Types.internalize x.accept
44
45
46

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

69
let dump_print ppf =
70
  while !to_print != [] do
71
72
73
74
75
76
77
78
79
80
81
    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
82

83
84
85
86
87
let print_node ppf n =
  Format.fprintf ppf "P%i" n.id;
  to_print := n :: !to_print;
  dump_print ppf

88

89
90
let counter = State.ref "Patterns.counter" 0

91
let dummy = (Types.empty,IdSet.empty,Dummy)
92
93
let make fv =
  incr counter;
94
  { id = !counter; descr = dummy; accept = Types.make (); fv = fv }
95
96

let define x ((accept,fv,_) as d) =
97
  (* assert (x.fv = fv); *)
98
  Types.define x.accept accept;
99
  x.descr <- d
100

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

135

136
137
138
139
140
141
module Node = struct
  type t = node
  let compare n1 n2 = n1.id - n2.id
  let equal n1 n2 = n1.id == n2.id
  let hash n = n.id

142
  let check n = ()
143
  let dump = print_node
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

  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;
202
      let n = { id = !counter; descr = dummy; accept = accept; fv = fv } in
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
      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
239

240
241
(* Pretty-print *)

242
module Pat = struct
243
  type t = descr
244
  let rec compare (_,_,d1) (_,_,d2) = if d1 == d2 then 0 else
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
    match (d1,d2) with
      | Constr t1, Constr t2 -> Types.compare t1 t2
      | Constr _, _ -> -1 | _, Constr _ -> 1

      | Cup (x1,y1), Cup (x2,y2) | Cap (x1,y1), Cap (x2,y2) ->
	  let c = compare x1 x2 in if c <> 0 then c 
	  else compare y1 y2
      | Cup _, _ -> -1 | _, Cup _ -> 1
      | Cap _, _ -> -1 | _, Cap _ -> 1

      | Times (x1,y1), Times (x2,y2) | Xml (x1,y1), Xml (x2,y2) ->
	  let c = Node.compare x1 x2 in if c <> 0 then c
	  else Node.compare y1 y2
      | Times _, _ -> -1 | _, Times _ -> 1
      | Xml _, _ -> -1 | _, Xml _ -> 1

      | Record (x1,y1), Record (x2,y2) ->
	  let c = LabelPool.compare x1 x2 in if c <> 0 then c
	  else Node.compare y1 y2
      | Record _, _ -> -1 | _, Record _ -> 1

      | Capture x1, Capture x2 ->
	  Id.compare x1 x2
      | Capture _, _ -> -1 | _, Capture _ -> 1

      | Constant (x1,y1), Constant (x2,y2) ->
	  let c = Id.compare x1 x2 in if c <> 0 then c
	  else Types.Const.compare y1 y2
      | Constant _, _ -> -1 | _, Constant _ -> 1

      | Dummy, Dummy -> assert false
276
277
278
279
280
281
282
283
284
285
286
287
288

  let equal p1 p2 = compare p1 p2 == 0

  let rec hash (_,_,d) = match d with
    | Constr t -> 1 + 17 * (Types.hash t)
    | Cup (p1,p2) -> 2 + 17 * (hash p1) + 257 * (hash p2)
    | Cap (p1,p2) -> 3 + 17 * (hash p1) + 257 * (hash p2)
    | Times (q1,q2) -> 4 + 17 * q1.id + 257 * q2.id
    | Xml (q1,q2) -> 5 + 17 * q1.id + 257 * q2.id
    | Record (l,q) -> 6 + 17 * (LabelPool.hash l) + 257 * q.id
    | Capture x -> 7 + (Id.hash x)
    | Constant (x,c) -> 8 + 17 * (Id.hash x) + 257 * (Types.Const.hash c)
    | Dummy -> assert false
289
290
291
end

module Print = struct
292
293
  module M = Map.Make(Pat)
  module S = Set.Make(Pat)
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
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
348
349
350
351
352
353
354
355
356

  let names = ref M.empty
  let printed = ref S.empty
  let toprint = Queue.create ()
  let id = ref 0

  let rec mark seen ((_,_,d) as p) =
    if (M.mem p !names) then ()
    else if (S.mem p seen) then
      (incr id;
       names := M.add p !id !names;
       Queue.add p toprint)
    else 
      let seen = S.add p seen in
      match d with
	| Cup (p1,p2) | Cap (p1,p2) -> mark seen p1; mark seen p2
	| Times (q1,q2) | Xml (q1,q2) -> mark seen q1.descr; mark seen q2.descr
	| Record (_,q) -> mark seen q.descr
	| _ -> ()

  let rec print ppf p =
    try 
      let i = M.find p !names in
      Format.fprintf ppf "P%i" i
    with Not_found ->
      real_print ppf p
  and real_print ppf (_,_,d) =  match d with
    | Constr t ->
	Types.Print.print 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 (q1,q2) ->
	Format.fprintf ppf "(%a,%a)" print q1.descr print q2.descr
    | Xml (q1,{ descr = (_,_,Times(q2,q3)) }) ->
	Format.fprintf ppf "<(%a) (%a)>(%a)" print q1.descr print q2.descr print q2.descr
    | Xml _ -> assert false
    | Record (l,q) ->
	Format.fprintf ppf "{%a=%a}" Label.print (LabelPool.value l) print q.descr
    | Capture x ->
	Format.fprintf ppf "%a" Ident.print x
    | Constant (x,c) ->
	Format.fprintf ppf "(%a:=%a)" Ident.print x Types.Print.print_const c
    | Dummy -> assert false
      
  let print ppf p =
    mark S.empty p;
    print ppf p;
    let first = ref true in
    (try while true do
       let p = Queue.pop toprint in
       if not (S.mem p !printed) then 
	 ( printed := S.add p !printed;
	   Format.fprintf ppf " %s@ @[%a=%a@]"
	     (if !first then (first := false; "where") else "and")
	     print p
	     real_print p
	);
     done with Queue.Empty -> ());
    id := 0;
    names := M.empty;
    printed := S.empty
357
358
359
360
361
362
363
364
365
366
367


  let print_xs ppf xs =
    Format.fprintf ppf "{";
    let rec aux = function
      | [] -> ()
      | [x] -> Ident.print ppf x
      | x::q -> Ident.print ppf x; Format.fprintf ppf ","; aux q
    in
    aux xs;
    Format.fprintf ppf "}"
368
369
370
end


371
372
373
374

(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
375
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
376
377
let times_res v1 v2 = Types.Positive.times v1 v2

378
(* Try with a hash-table *)
379
module MemoFilter = Map.Make 
380
  (struct 
381
     type t = Types.t * node 
382
383
     let compare (t1,n1) (t2,n2) = 
       if n1.id < n2.id then -1 else if n1.id > n2.id then 1 else
384
       Types.compare t1 t2
385
   end)
386
387
388

let memo_filter = ref MemoFilter.empty

389
let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
390
(* TODO: avoid is_empty t when t is not changing (Cap) *)
391
392
393
394
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
395
      | Constr _ -> IdMap.empty
396
      | Cup ((a,_,_) as d1,d2) ->
397
	  IdMap.merge cup_res
398
399
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
400
      | Cap (d1,d2) ->
401
	  IdMap.merge cup_res (filter_descr t d1) (filter_descr t d2)
402
403
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
404
405
406
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
407
	  IdMap.singleton c (Types.Positive.ty t)
408
      | Constant (c, cst) ->
409
	  IdMap.singleton c (Types.Positive.ty (Types.constant cst))
410
      | Dummy -> assert false
411

412
413
414
415
and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
416
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
417
       in
418
       IdMap.merge cup_res accu term
419
420
421
422
423
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


424
and filter_node t p : Types.Positive.v id_map =
425
426
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
427
    let (_,fv,_) as d = descr p in
428
    let res = IdMap.map_from_slist (fun _ -> Types.Positive.forward ()) fv in
429
430
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
431
    IdMap.collide Types.Positive.define res r;
432
433
434
435
436
    r

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

439
440
441
442
443
let filter_descr t p =
  let r = filter_descr t p in
  memo_filter :=  MemoFilter.empty;
  IdMap.get (IdMap.map Types.Positive.solve r)

444

445
(* Normal forms for patterns and compilation *)
446

447
448
let min (a:int) (b:int) = if a < b then a else b

449
450
451
let any_basic = Types.Record.or_absent Types.non_constructed


452
module Normal = struct
453

454
  type source = 
455
456
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
457
  type result = source id_map
458

459
460
461
462
463
464
465
  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
466
      | SConst c1, SConst c2 -> Types.Const.compare c1 c2
467
468
469
470
471
472

  let hash_source = function
    | SCatch -> 1
    | SLeft -> 2
    | SRight -> 3
    | SRecompose -> 4
473
    | SConst c -> Types.Const.hash c
474
475
476
477
478
479
480
481
    
  let compare_result r1 r2 =
    IdMap.compare compare_source r1 r2

  let hash_result r =
    IdMap.hash hash_source r


482
483
484
485
486
  let print_result ppf r = Format.fprintf ppf "<result>"
  let print_result_option ppf = function
    | Some x -> Format.fprintf ppf "Some(%a)" print_result x
    | None -> Format.fprintf ppf "None"

487
  module NodeSet = 
488
489
    SortedList.Make(Node)

490

491
  type nnf = NodeSet.t * Types.t (* pl,t;   t <= \accept{pl} *)
492

493
494
495
496
497
498
499
500
  let check_nnf (pl,t) =
    List.iter (fun p -> assert(Types.subtype t (Types.descr p.accept)))
      (NodeSet.get pl)

  let print_nnf ppf (pl,t) =
    Format.fprintf ppf "@[(pl=%a;t=%a)@]" NodeSet.dump pl Types.Print.print t
			    

501
502
  let compare_nnf (l1,t1) (l2,t2) =
    let c = NodeSet.compare l1 l2 in if c <> 0 then c
503
    else Types.compare t1 t2
504
505

  let hash_nnf (l,t) =
506
    (NodeSet.hash l) + 17 * (Types.hash t)
507
508
509
510

  module NLineBasic = 
    SortedList.Make(
      struct
511
	include Custom.Dummy
512
	let serialize s _ = failwith "Patterns.NLineBasic.serialize"
513
	type t = result * Types.t
514
515
	let compare (r1,t1) (r2,t2) =
	  let c = compare_result r1 r2 in if c <> 0 then c
516
	  else Types.compare t1 t2
517
	let equal x y = compare x y == 0
518
	let hash (r,t) = hash_result r + 17 * Types.hash t
519
520
521
522
523
524
      end
    )

  module NLineProd = 
    SortedList.Make(
      struct
525
(*	include Custom.Dummy*)
526
	let serialize s _ = failwith "Patterns.NLineProd.serialize"
527
528
529
530
531
532
533
	let deserialize s = failwith "Patterns.NLineProd.deserialize"
	let check x = ()
	let dump ppf (r,x,y) =
	  Format.fprintf ppf "@[(result=%a;x=%a;y=%a)@]" 
	    print_result r
	    print_nnf x
	    print_nnf y
534
	type t = result * nnf * nnf
535
536
537
538
	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
539
	let equal x y = compare x y == 0
540
541
542
543
544
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

545
  type record =
546
    | RecNolabel of result option * result option
547
    | RecLabel of label * NLineProd.t
548
  type t = {
549
    nfv    : fv;
550
    ncatchv: fv;
551
552
553
554
    na     : Types.t;
    nbasic : NLineBasic.t;
    nprod  : NLineProd.t;
    nxml   : NLineProd.t;
555
    nrecord: record
556
  }
557

558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
  let print_record ppf = function
    | RecLabel (lab,l) ->
	Format.fprintf ppf "RecLabel(@[%a@],@ @[%a@])"
	  Label.print (LabelPool.value lab)
	  NLineProd.dump l
    | RecNolabel (a,b) -> 
	Format.fprintf ppf "RecNolabel(@[%a@],@[%a@])" 
	  print_result_option a
	  print_result_option b
  let print ppf nf =
    Format.fprintf ppf "@[NF{na=%a;@[nrecord=@ @[%a@]@]}@]" 
      Types.Print.print nf.na
      print_record nf.nrecord
      

573
574
575
576
577
578
  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
579
      else let c = Types.compare t1.na t2.na in if c <> 0 then c
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
      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
601

602
  let fus = IdMap.union_disj
603

604
605
606
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
607
608
609
      nbasic = NLineBasic.empty; 
      nprod = NLineProd.empty; 
      nxml = NLineProd.empty;
610
      nrecord = (match lab with 
611
		   | Some l -> RecLabel (l,NLineProd.empty)
612
		   | None -> RecNolabel (None,None))
613
    }
614
  let dummy = nempty None
615
616
617
618
619
620


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
621
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
622
      na      = Types.cup nf1.na nf2.na;
623
624
625
      nbasic  = NLineBasic.cup nf1.nbasic nf2.nbasic;
      nprod   = NLineProd.cup nf1.nprod nf2.nprod;
      nxml    = NLineProd.cup nf1.nxml nf2.nxml;
626
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
627
		   | RecLabel (l1,r1), RecLabel (l2,r2) -> 
628
		       (* assert (l1 = l2); *) RecLabel (l1, NLineProd.cup r1 r2)
629
		   | RecNolabel (x1,y1), RecNolabel (x2,y2) -> 
630
631
		       RecNolabel((if x1 == None then x2 else x1),
				(if y1 == None then y2 else y1))
632
		   | _ -> assert false)
633
634
635
    }

  let double_fold f l1 l2 =
636
637
638
639
640
641
    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)
642
643
	 
  let ncap nf1 nf2 =
644
    let prod accu (res1,(pl1,t1),(ql1,s1)) (res2,(pl2,t2),(ql2,s2)) =
645
646
647
648
      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
649
650
	  (fus res1 res2, (NodeSet.cup pl1 pl2,t),(NodeSet.cup ql1 ql2,s)) 
	  :: accu
651
652
653
654
655
656
    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
657
    let record r1 r2 = match r1,r2 with
658
      | RecLabel (l1,r1), RecLabel (l2,r2) ->
659
	  (* assert (l1 = l2); *)
660
	  RecLabel(l1, NLineProd.from_list (double_fold_prod prod r1 r2))
661
      | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
662
663
664
665
666
667
	  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
668
	  RecNolabel (x,y)
669
      | _ -> assert false
670
    in
671
672
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
673
      na = Types.cap nf1.na nf2.na;
674
675
676
677
678
679
      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;
680
681
    }

682
683
684
685
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

686
  let empty_res = IdMap.empty
687

688
  let ntimes lab acc p q = 
689
690
691
    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 
692
    { nempty lab with 
693
	nfv = IdSet.cup p.fv q.fv; 
694
	na = acc;
695
	nprod = NLineProd.singleton (src, nnode p, nnode q);
696
697
    }

698
  let nxml lab acc p q = 
699
700
701
    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 
702
    { nempty lab with 
703
	nfv = IdSet.cup p.fv q.fv; 
704
	na = acc;
705
	nxml =  NLineProd.singleton (src, nnode p, nnode q);
706
707
    }
    
708
709
710
711
712
713
714
715
716
717
  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;
718
		nrecord = RecLabel(label, 
719
				 NLineProd.singleton (src,nnode p, ncany))}
720
721
722
723
724
725
726
727
	  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;
728
729
730
731
		nrecord = 
		      RecLabel(label,
		        NLineProd.singleton(src,nc Types.Record.any_or_absent, 
 			 nnode p') )}
732
733
734
	  

  let nconstr lab t =
735
736
    let aux l = NLineProd.from_list
		(List.map (fun (t1,t2) -> empty_res, nc t1,nc t2) l) in
737
738
739
740
    let record = 
      match lab with
	| None ->
	    let (x,y) = Types.Record.empty_cases t in
741
	    RecNolabel ((if x then Some empty_res else None), 
742
743
		      (if y then Some empty_res else None))
	| Some l ->
744
745
746
747
748
749
750
751
752
753
(*
	    let ppf = Format.std_formatter in
	    Format.fprintf ppf "Constr record t=%a l=%a@."
	      Types.Print.print t Label.print (LabelPool.value l);
	    let sp = Types.Record.split_normal t l in
	    List.iter (fun (t1,t2) ->
			 Format.fprintf ppf "t1=%a t2=%a@."
			   Types.Print.print t1
			   Types.Print.print t2) sp;
*)
754
	    RecLabel (l,aux (Types.Record.split_normal t l))
755
756
    in	      
    { nempty lab with
757
	na = t;
758
	nbasic = NLineBasic.singleton (empty_res, Types.cap t any_basic);
759
760
761
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
762
763
    }

764
  let nconstant lab x c = 
765
766
767
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
768
      na = Types.any;
769
770
771
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
772
      nrecord = match lab with
773
	| None -> RecNolabel (Some l, Some l)
774
	| Some lab -> 
775
776
777
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
				 ncany))
778
779
    }

780
  let ncapture lab x = 
781
782
783
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
784
      na = Types.any;
785
786
787
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
788
      nrecord = match lab with
789
	| None -> RecNolabel (Some l, Some l)
790
	| Some lab -> 
791
792
793
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
			         ncany))
794
795
    }

796
  let rec nnormal lab (acc,fv,d) =
797
    if Types.is_empty acc 
798
    then nempty lab
799
    else match d with
800
801
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
802
      | Cup ((acc1,_,_) as p,q) -> 
803
804
805
806
807
808
809
	  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
810
      | Dummy -> assert false
811
812
813
814
815
816

(*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 
817
    then LabelPool.dummy_max
818
819
820
821
822
823
    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
824
      | _ -> LabelPool.dummy_max
825

826
827
828
   
  let remove_catchv n =
    let ncv = n.ncatchv in
829
830
831
832
    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
833
    { nfv     = IdSet.diff n.nfv ncv;
834
835
      ncatchv = n.ncatchv;
      na      = n.na;
836
837
838
      nbasic  = nlinesbasic n.nbasic;
      nprod   = nlinesprod n.nprod;
      nxml    = nlinesprod n.nxml;
839
      nrecord = (match n.nrecord with
840
		   | RecNolabel (x,y) ->
841
842
843
844
845
846
		       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
847
		       RecNolabel (x,y)
848
		   | RecLabel (lab,l) -> RecLabel (lab, nlinesprod l))
849
850
    }

851
852
853
  let print_node_list ppf pl =
    List.iter (fun p -> Format.fprintf ppf "%a;" Node.dump p) pl

854
  let normal l t pl =
855
    remove_catchv
856
857
858
859
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877

(*
  let normal l t pl =
    let nf = normal l t pl in
    (match l with Some l ->
      Format.fprintf Format.std_formatter
	"normal(l=%a;t=%a;pl=%a)=%a@." 
	Label.print (LabelPool.value l)
	Types.Print.print t
	print_node_list pl
	print nf
      | None -> Format.fprintf Format.std_formatter
	"normal(t=%a;pl=%a)=%a@." 
	Types.Print.print t
	print_node_list pl
	print nf);
    nf
*)
878
end
879
880


881
882
module Compile = 
struct
883
  type actions =
884
885
    | AIgnore of result
    | AKind of actions_kind
886
  and actions_kind = {
887
    basic: (Types.t * result) list;
888
889
    atoms: result Atoms.map;
    chars: result Chars.map;
890
    prod: result dispatch dispatch;
891
    xml: result dispatch dispatch;
892
893
894
    record: record option;
  }
  and record = 
895
    | RecLabel of label * result dispatch dispatch
896
    | RecNolabel of result option * result option
897
      
898
  and 'a dispatch =
899
900
901
902
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
903
904

  and result = int * source array
905
  and source = 
906
907
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
908
909
      
  and return_code = 
910
      Types.t * int *   (* accepted type, arity *)
911
      (int * int id_map) list
912
913

  and interface =
914
915
    [ `Result of int
    | `Switch of interface * interface
916
917
918
919
    | `None ]

  and dispatcher = {
    id : int;
920
    t  : Types.t;
921
    pl : Normal.t array;
922
    label : label option;
923
924
    interface : interface;
    codes : return_code array;
925
926
    mutable actions : actions option;
    mutable printed : bool
927
  }
928

929
930
931
932
933
934
935
  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
936
      | Const x, Const y -> Types.Const.equal x y 
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
      | 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


953
954
  let array_for_all f a =
    let rec aux f a i =
955
      if i == Array.length a then true
956
957
958
959
960
961
      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 =
962
      if i == Array.length a then true
963
964
965
966
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

967
  let combine_kind basic prod xml record =
968
969
970
971
972
973
974
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
975
976
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
977
	| _ -> raise Exit in
978
      let rs = match xml with
979
980
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
981
	| _ -> raise Exit in
982
983
      let rs = match record with
	| None -> rs
984
985
	| Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
	| Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
986
987
	| _ -> raise Exit in
      match rs with
988
	| ((_, ret) as r) :: rs when 
989
	    List.for_all ( equal_result r ) rs 
990
	    && array_for_all 
991
992
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
993
994
	| _ -> raise Exit
    )
995
996
997
998
    with Exit -> 
      AKind 
      { basic = basic;
	atoms = 
999
	  Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic);
1000
	chars = 
1001
	  Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic);
1002
1003
	prod = prod; 
	xml = xml; 
1004
1005
	record = record;
      }
1006
      
1007
1008
  let combine f (disp,act) =
    if Array.length act == 0 then Impossible
1009
    else
1010
1011
      if (array_for_all (fun (_,ar,_) -> ar == 0) disp.codes) 
	 && (array_for_all ( f act.(0) ) act) then
1012
	   Ignore act.(0)
1013
      else
1014
	Dispatch (disp, act)
1015
1016
1017


  let detect_right_tail_call = function
1018
    | Dispatch (disp,branches) 
1019
1020
1021
	when
	  array_for_all_i
	    (fun i (code,ret) ->