patterns.ml 33.5 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
26
and node = {
  id : int;
27
  mutable descr : descr option;
28
  accept : Types.Node.t;
29
  fv : fv
30
31
32
33
34
35
36
37
38
39
} and descr = Types.t * fv * d


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
end
40

41
42
43
44
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
45
46
47

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

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


83
84
85
86
87
let counter = State.ref "Patterns.counter" 0

let make fv =
  incr counter;
  { id = !counter; descr = None; accept = Types.make (); fv = fv }
88
89

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

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

128

129

130
131
132
133

(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
134
let empty_res fv = IdMap.constant (Types.Positive.ty Types.empty) fv
135
136
let times_res v1 v2 = Types.Positive.times v1 v2

137
(* Try with a hash-table *)
138
module MemoFilter = Map.Make 
139
  (struct 
140
     type t = Types.t * node 
141
142
     let compare (t1,n1) (t2,n2) = 
       if n1.id < n2.id then -1 else if n1.id > n2.id then 1 else
143
       Types.compare t1 t2
144
   end)
145
146
147

let memo_filter = ref MemoFilter.empty

148
let rec filter_descr t (_,fv,d) : Types.Positive.v id_map =
149
(* TODO: avoid is_empty t when t is not changing (Cap) *)
150
151
152
153
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
154
      | Constr _ -> IdMap.empty
155
      | Cup ((a,_,_) as d1,d2) ->
156
	  IdMap.merge cup_res
157
158
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
159
      | Cap (d1,d2) ->
160
	  IdMap.merge cup_res (filter_descr t d1) (filter_descr t d2)
161
162
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
163
164
165
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
166
	  IdMap.singleton c (Types.Positive.ty t)
167
      | Constant (c, cst) ->
168
	  IdMap.singleton c (Types.Positive.ty (Types.constant cst))
169

170
171
172
173
and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
174
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
175
       in
176
       IdMap.merge cup_res accu term
177
178
179
180
181
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


182
and filter_node t p : Types.Positive.v id_map =
183
184
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
185
    let (_,fv,_) as d = descr p in
186
    let res = IdMap.map_from_slist (fun _ -> Types.Positive.forward ()) fv in
187
188
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
189
    IdMap.collide Types.Positive.define res r;
190
191
192
193
194
    r

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


198
(* Normal forms for patterns and compilation *)
199

200
201
let min (a:int) (b:int) = if a < b then a else b

202
203
204
let any_basic = Types.Record.or_absent Types.non_constructed


205
module Normal = struct
206

207
  type source = 
208
209
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
210
  type result = source id_map
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
  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 = 
236
237
    SortedList.Make(Node)

238

239
  type nnf = NodeSet.t * Types.t (* pl,t;   t <= \accept{pl} *)
240
241
242

  let compare_nnf (l1,t1) (l2,t2) =
    let c = NodeSet.compare l1 l2 in if c <> 0 then c
243
    else Types.compare t1 t2
244
245

  let hash_nnf (l,t) =
246
    (NodeSet.hash l) + 17 * (Types.hash t)
247
248
249
250

  module NLineBasic = 
    SortedList.Make(
      struct
251
252
	include Custom.Dummy
	type t = result * Types.t
253
254
	let compare (r1,t1) (r2,t2) =
	  let c = compare_result r1 r2 in if c <> 0 then c
255
	  else Types.compare t1 t2
256
	let equal x y = compare x y == 0
257
	let hash (r,t) = hash_result r + 17 * Types.hash t
258
259
260
261
262
263
      end
    )

  module NLineProd = 
    SortedList.Make(
      struct
264
265
	include Custom.Dummy
	type t = result * nnf * nnf
266
267
268
269
	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
270
	let equal x y = compare x y == 0
271
272
273
274
275
	let hash (r,x,y) =
	  hash_result r + 17 * (hash_nnf x) + 267 * (hash_nnf y)
      end
    )

276
  type record =
277
    | RecNolabel of result option * result option
278
    | RecLabel of label * NLineProd.t
279
  type t = {
280
    nfv    : fv;
281
    ncatchv: fv;
282
283
284
285
    na     : Types.t;
    nbasic : NLineBasic.t;
    nprod  : NLineProd.t;
    nxml   : NLineProd.t;
286
    nrecord: record
287
  }
288

289
290
291
292
293
294
  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
295
      else let c = Types.compare t1.na t2.na in if c <> 0 then c
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
      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
317

318
  let fus = IdMap.union_disj
319

320
321
322
  let nempty lab = 
    { nfv = IdSet.empty; ncatchv = IdSet.empty; 
      na = Types.empty;
323
324
325
      nbasic = NLineBasic.empty; 
      nprod = NLineProd.empty; 
      nxml = NLineProd.empty;
326
      nrecord = (match lab with 
327
		   | Some l -> RecLabel (l,NLineProd.empty)
328
		   | None -> RecNolabel (None,None))
329
    }
330
  let dummy = nempty None
331
332
333
334
335
336


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
337
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
338
      na      = Types.cup nf1.na nf2.na;
339
340
341
      nbasic  = NLineBasic.cup nf1.nbasic nf2.nbasic;
      nprod   = NLineProd.cup nf1.nprod nf2.nprod;
      nxml    = NLineProd.cup nf1.nxml nf2.nxml;
342
      nrecord = (match (nf1.nrecord,nf2.nrecord) with
343
		   | RecLabel (l1,r1), RecLabel (l2,r2) -> 
344
		       (* assert (l1 = l2); *) RecLabel (l1, NLineProd.cup r1 r2)
345
		   | RecNolabel (x1,y1), RecNolabel (x2,y2) -> 
346
347
		       RecNolabel((if x1 == None then x2 else x1),
				(if y1 == None then y2 else y1))
348
		   | _ -> assert false)
349
350
351
    }

  let double_fold f l1 l2 =
352
353
354
355
356
357
    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)
358
359
	 
  let ncap nf1 nf2 =
360
    let prod accu (res1,(pl1,t1),(ql1,s1)) (res2,(pl2,t2),(ql2,s2)) =
361
362
363
364
      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
365
366
	  (fus res1 res2, (NodeSet.cup pl1 pl2,t),(NodeSet.cup ql1 ql2,s)) 
	  :: accu
367
368
369
370
371
372
    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
373
    let record r1 r2 = match r1,r2 with
374
      | RecLabel (l1,r1), RecLabel (l2,r2) ->
375
	  (* assert (l1 = l2); *)
376
	  RecLabel(l1, NLineProd.from_list (double_fold_prod prod r1 r2))
377
      | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
378
379
380
381
382
383
	  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
384
	  RecNolabel (x,y)
385
      | _ -> assert false
386
    in
387
388
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
389
      na = Types.cap nf1.na nf2.na;
390
391
392
393
394
395
      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;
396
397
    }

398
399
400
401
  let nnode p = NodeSet.singleton p, Types.descr p.accept
  let nc t = NodeSet.empty, t
  let ncany = nc Types.any

402
  let empty_res = IdMap.empty
403

404
  let ntimes lab acc p q = 
405
406
407
    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 
408
    { nempty lab with 
409
	nfv = IdSet.cup p.fv q.fv; 
410
	na = acc;
411
	nprod = NLineProd.singleton (src, nnode p, nnode q);
412
413
    }

414
  let nxml lab acc p q = 
415
416
417
    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 
418
    { nempty lab with 
419
	nfv = IdSet.cup p.fv q.fv; 
420
	na = acc;
421
	nxml =  NLineProd.singleton (src, nnode p, nnode q);
422
423
    }
    
424
425
426
427
428
429
430
431
432
433
  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;
434
		nrecord = RecLabel(label, 
435
				 NLineProd.singleton (src,nnode p, ncany))}
436
437
438
439
440
441
442
443
	  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;
444
445
446
447
		nrecord = 
		      RecLabel(label,
		        NLineProd.singleton(src,nc Types.Record.any_or_absent, 
 			 nnode p') )}
448
449
450
	  

  let nconstr lab t =
451
452
    let aux l = NLineProd.from_list
		(List.map (fun (t1,t2) -> empty_res, nc t1,nc t2) l) in
453
454
455
456
    let record = 
      match lab with
	| None ->
	    let (x,y) = Types.Record.empty_cases t in
457
	    RecNolabel ((if x then Some empty_res else None), 
458
459
		      (if y then Some empty_res else None))
	| Some l ->
460
	    RecLabel (l,aux (Types.Record.split_normal t l))
461
462
    in	      
    { nempty lab with
463
	na = t;
464
	nbasic = NLineBasic.singleton (empty_res, Types.cap t any_basic);
465
466
467
	nprod = aux (Types.Product.normal t);
	nxml  = aux (Types.Product.normal ~kind:`XML t);
	nrecord = record
468
469
    }

470
  let nconstant lab x c = 
471
472
473
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
474
      na = Types.any;
475
476
477
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
478
      nrecord = match lab with
479
	| None -> RecNolabel (Some l, Some l)
480
	| Some lab -> 
481
482
483
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
				 ncany))
484
485
    }

486
  let ncapture lab x = 
487
488
489
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
490
      na = Types.any;
491
492
493
      nbasic = NLineBasic.singleton (l,any_basic); 
      nprod  = NLineProd.singleton (l,ncany,ncany);
      nxml   = NLineProd.singleton (l,ncany,ncany);
494
      nrecord = match lab with
495
	| None -> RecNolabel (Some l, Some l)
496
	| Some lab -> 
497
498
499
	    RecLabel (lab, NLineProd.singleton 
			(l,nc Types.Record.any_or_absent,
			         ncany))
500
501
    }

502
  let rec nnormal lab (acc,fv,d) =
503
    if Types.is_empty acc 
504
    then nempty lab
505
    else match d with
506
507
      | Constr t -> nconstr lab t
      | Cap (p,q) -> ncap (nnormal lab p) (nnormal lab q)
508
      | Cup ((acc1,_,_) as p,q) -> 
509
510
511
512
513
514
515
516
517
518
519
520
521
	  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 
522
    then LabelPool.dummy_max
523
524
525
526
527
528
    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
529
      | _ -> LabelPool.dummy_max
530

531
532
533
   
  let remove_catchv n =
    let ncv = n.ncatchv in
534
535
536
537
    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
538
    { nfv     = IdSet.diff n.nfv ncv;
539
540
      ncatchv = n.ncatchv;
      na      = n.na;
541
542
543
      nbasic  = nlinesbasic n.nbasic;
      nprod   = nlinesprod n.nprod;
      nxml    = nlinesprod n.nxml;
544
      nrecord = (match n.nrecord with
545
		   | RecNolabel (x,y) ->
546
547
548
549
550
551
		       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
552
		       RecNolabel (x,y)
553
		   | RecLabel (lab,l) -> RecLabel (lab, nlinesprod l))
554
555
    }

556
  let normal l t pl =
557
    remove_catchv
558
559
560
561
      (List.fold_left 
	 (fun a p -> ncap a (nnormal l (descr p))) 
	 (nconstr l t) 
	 pl)
562
end
563
564


565
566
module Compile = 
struct
567
  type actions =
568
569
    | AIgnore of result
    | AKind of actions_kind
570
  and actions_kind = {
571
    basic: (Types.t * result) list;
572
573
    atoms: result Atoms.map;
    chars: result Chars.map;
574
    prod: result dispatch dispatch;
575
    xml: result dispatch dispatch;
576
577
578
    record: record option;
  }
  and record = 
579
    | RecLabel of label * result dispatch dispatch
580
    | RecNolabel of result option * result option
581
      
582
  and 'a dispatch =
583
584
585
586
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible
587
588

  and result = int * source array
589
  and source = 
590
591
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
592
593
      
  and return_code = 
594
      Types.t * int *   (* accepted type, arity *)
595
      (int * int id_map) list
596
597

  and interface =
598
599
    [ `Result of int
    | `Switch of interface * interface
600
601
602
603
    | `None ]

  and dispatcher = {
    id : int;
604
    t  : Types.t;
605
    pl : Normal.t array;
606
    label : label option;
607
608
    interface : interface;
    codes : return_code array;
609
610
    mutable actions : actions option;
    mutable printed : bool
611
  }
612

613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
  let equal_array f a1 a2 =
    let rec aux i = (i < 0) || ((f a1.(i) a2.(i)) && (aux (i - 1))) in
    let l1 = Array.length a1 and l2 = Array.length a2 in
    (l1 == l2) && (aux (l1 - 1))

  let equal_source s1 s2 =
    (s1 == s2) || match (s1,s2) with
      | Const x, Const y -> Types.equal_const x y 
      | Left x, Left y -> x == y
      | Right x, Right y -> x == y
      | Recompose (x1,x2), Recompose (y1,y2) -> (x1 == y1) && (x2 == y2)
      | _ -> false

  let equal_result (r1,s1) (r2,s2) =
    (r1 == r2) && (equal_array equal_source s1 s2)

  let equal_result_dispatch d1 d2 =
    (d1 == d2) || match (d1,d2) with
      | Dispatch (d1,a1), Dispatch (d2,a2) -> (d1 == d2) && (equal_array equal_result a1 a2)
      | TailCall d1, TailCall d2 -> d1 == d2
      | Ignore a1, Ignore a2 -> equal_result a1 a2
      | _ -> false


637
638
  let array_for_all f a =
    let rec aux f a i =
639
      if i == Array.length a then true
640
641
642
643
644
645
      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 =
646
      if i == Array.length a then true
647
648
649
650
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

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


  let detect_right_tail_call = function
701
    | Dispatch (disp,branches) 
702
703
704
	when
	  array_for_all_i
	    (fun i (code,ret) ->
705
	       (i == code) && 
706
707
	       (array_for_all_i 
		  (fun pos -> 
708
		     function Right j when pos == j -> true | _ -> false)
709
710
711
		  ret
	       )
	    ) branches
712
	  -> TailCall disp
713
714
715
    | x -> x

  let detect_left_tail_call = function
716
    | Dispatch (disp,branches)
717
718
719
720
	when
	  array_for_all_i
	    (fun i -> 
	       function 
721
		 | Ignore (code,ret) ->
722
		     (i == code) &&
723
724
		     (array_for_all_i 
			(fun pos -> 
725
			   function Left j when pos == j -> true | _ -> false)
726
727
728
729
730
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
731
	 TailCall disp
732
733
    | x -> x
   
734
735
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
736
		 
737
738
739
740
741
742
  module NfMap = Map.Make(
    struct 
      type t = Normal.t
      let compare = Normal.compare_nf
    end)

743
744
  module DispMap = Map.Make(
    struct
745
      type t = Types.t * Normal.t array
746
747
748
749
750
751
752
753

      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) =
754
	let c = Types.compare t1 t2 in if c <> 0 then c 
755
756
757
	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)
758
759
    end
  )
760
761

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

  let create_result pl =
809
810
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])
811
812
813
814
815
816

  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)
    
817
  let conv_source_basic s = match s with
818
819
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
820
821
    | _ -> assert false

822
  let assoc v l =
823
    try IdMap.assoc v l with Not_found -> -1
824

825
  let conv_source_prod left right v s = match s with
826
827
828
829
830
    | 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)
831

832
833
  module TypeList = SortedList.Make(Types)
  let dispatch_basic disp : (Types.t * result) list =
834
(* TODO: try other algo, using disp.codes .... *)
835
836
837
838
    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
839
      Array.iteri (fun i -> Normal.NLineBasic.iter (aux i)) pl;
840
      TypeList.Map.get (TypeList.Map.from_list (@) !accu) in
841

842
    let t = Types.cap any_basic disp.t in
843
    let accu = ref [] in
844
    let rec aux (success : (int * Normal.result) list) t l = 
845
846
847
      if Types.non_empty t 
      then match l with
	| [] ->
848
849
850
851
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
852
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
853
854
855
856
	    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
857
    in
858
    aux [] t tests;
Pietro Abate's avatar