value.ml 25 KB
Newer Older
1
open Ident
2
open Encodings
3

4
5
type t =
  | Pair of t * t
6
  | Xml of t * t * t
7
  | XmlNs of t * t * t * Ns.table
8
  | Record of t Imap.t
9
10
11
  | Atom of Atoms.V.t
  | Integer of Intervals.V.t
  | Char of Chars.V.t
12
  | Abstraction of (Types.descr * Types.descr) list option * (t -> t)
13
  | Abstract of Types.Abstract.V.t
14
  | String_latin1 of int * int * string * t
15
  | String_utf8 of Utf8.uindex * Utf8.uindex * Utf8.t * t
16
  | Concat of t * t
17
  | Absent
18

19
20
21
22
23
24
(* 
  The only representation of the empty sequence is nil.
  In particular, in String_latin1 and String_utf8, the string cannot be empty.
*)

let dump_forward = ref (fun _ _ -> assert false)
25

26
27
exception CDuceExn of t

28
let nil = Atom Sequence.nil_atom
29
30
31
32
33
34
35
36
37
let string_latin1 s = 
  if String.length s = 0 then nil
  else String_latin1 (0,String.length s, s, nil)
let string_utf8 s = 
  if String.length (Utf8.get_str s) = 0 then nil
  else String_utf8 (Utf8.start_index s,Utf8.end_index s, s, nil)
let substring_utf8 i j s q =
  if Utf8.equal_index i j then q 
  else String_utf8 (i,j,s,q)
38
39
let vtrue = Atom (Atoms.V.mk_ascii "true")
let vfalse = Atom (Atoms.V.mk_ascii "false")
40
41
let vbool x = if x then vtrue else vfalse

42
let vrecord l =
43
  let l = List.map (fun (lab,v) -> Upool.int lab, v) l in
44
  Record (Imap.create (Array.of_list l))
45
46

let get_fields = function
47
  | Record map -> Obj.magic (Imap.elements map)
48
  | _ -> raise (Invalid_argument "Value.get_fields")
49

50
51
52
let rec sequence = function
  | [] -> nil
  | h::t -> Pair (h, sequence t)
53

54
55
56
57
58
59
let rec sequence_rev accu = function
  | [] -> accu
  | h::t -> sequence_rev (Pair (h,accu)) t

let sequence_rev l = sequence_rev nil l

60
61
62
63
64
65
let sequence_of_array a =
  let rec aux accu i =
    if (i = 0) then accu
    else let i = pred i in aux (Pair (a.(i), accu)) i in
  aux nil (Array.length a)

66
67
68
69
70
71
72
let tuple_of_array a =
  let rec aux accu i =
    if (i = 0) then accu
    else let i = pred i in aux (Pair (a.(i), accu)) i in
  let n = Array.length a in
  aux a.(n) (pred n)

73
74
75
76
let concat v1 v2 = 
  match (v1,v2) with
    | (Atom _, v) | (v, Atom _) -> v
    | (v1,v2) -> Concat (v1,v2)
77

78
79
80
let append v1 v2 =
  concat v1 (Pair (v2,nil))

81
let raise' v = raise (CDuceExn v)
82
let failwith' s = raise' (string_latin1 s)
83

84

85
let rec const = function
86
87
88
  | Types.Integer i -> Integer i
  | Types.Atom a -> Atom a
  | Types.Char c -> Char c
89
90
91
  | Types.Pair (x,y) -> Pair (const x, const y)
  | Types.Xml (x, Types.Pair (y, z)) -> Xml (const x, const y, const z)
  | Types.Xml (_,_) -> assert false
92
  | Types.Record x -> 
93
      let x = LabelMap.mapi_to_list (fun l c -> (Upool.int l,const c)) x in
94
      Record (Imap.create (Array.of_list x))
95
96
  | Types.String (i,j,s,c) -> String_utf8 (i,j,s, const c)

97
98
let rec inv_const = function
  | Pair (x, y) -> Types.Pair (inv_const x, inv_const y)
99
  | Xml (x, y, z) | XmlNs (x,y,z,_) ->
100
      Types.Pair (inv_const x, Types.Pair (inv_const y, inv_const z))
101
102
  | Record x -> 
      let x = Imap.elements x in
103
      let x = List.map (fun (l,c) -> (Label.from_int l,inv_const c)) x in
104
      Types.Record (LabelMap.from_list_disj x)
105
106
107
108
109
110
111
112
113
114
115
116
117
118
  | Atom a -> Types.Atom a
  | Integer i -> Types.Integer i
  | Char c -> Types.Char c
  | String_latin1 (_, _, s, v) ->
      let s = Utf8.mk s in
      Types.String (Utf8.start_index s, Utf8.end_index s, s, inv_const v)
  | String_utf8 (i, j, s, v) -> Types.String (i, j, s, inv_const v)
  | Concat (x, y) as v ->
      let rec children = function
        | Concat (x, y) -> children x @ children y
        | x -> [x]
      in
      inv_const (sequence (children v))
  | _ -> failwith "inv_const"
119
120
121
122
123
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

let normalize_string_latin1 i j s q = 
  if i = j then q else
    Pair (Char (Chars.V.mk_char (String.unsafe_get s i)), String_latin1 (succ i,j,s,q))

let normalize_string_utf8 i j s q = 
  if Utf8.equal_index i j then q 
  else
    let (c,i) = Utf8.next s i in
    Pair (Char (Chars.V.mk_int c), String_utf8 (i,j,s,q))



(***** The dirty things **********)

type pair = { dummy : t; mutable pair_tl : t }
type str  = { dummy1 : t; dummy2 : t; dummy3 : t; mutable str_tl : t }

(* Could optimize this function by changing the order of the fields
   in String_latin1, String_utf8 *)

let set_cdr cell tl =
  match cell with
    | Pair (_,_) -> (Obj.magic cell).pair_tl <- tl
    | String_latin1 (_,_,_,_) 
    | String_utf8(_,_,_,_)-> (Obj.magic cell).str_tl <- tl
    | _ -> assert false

let rec append_cdr cell tl =
  match tl with
    | Concat (x,y) ->
	append_cdr (append_cdr cell x) y
    | Pair (x,tl) -> 
	let cell' = Pair (x,Absent) in
	set_cdr cell cell';
	append_cdr cell' tl
    | String_latin1 (s,i,j,tl) ->
	let cell' = String_latin1 (s,i,j,Absent) in
	set_cdr cell cell';
	append_cdr cell' tl
    | String_utf8 (s,i,j,tl) ->
	let cell' = String_utf8 (s,i,j,Absent) in
	set_cdr cell cell';
	append_cdr cell' tl
    | _ -> cell


let rec flatten = function
  | Pair (x,y) -> concat x (flatten y)
  | Concat (x,y) -> concat (flatten x) (flatten y)
  | q -> q

let eval_lazy_concat v =
  let accu = Obj.magic (Pair (nil,Absent)) in
  let rec aux accu = function
    | Concat (x,y) -> aux (append_cdr accu x) y
    | v -> set_cdr accu v
  in
  aux accu v;
  let nv = match snd accu with 
    | Pair (_,_) as nv -> nv
    | String_latin1 (i,j,s,q) -> normalize_string_latin1 i j s q
    | String_utf8 (i,j,s,q) -> normalize_string_utf8 i j s q
    | _ -> assert false in
  let v = Obj.repr v in
  let nv = Obj.repr nv in
  Obj.set_tag v (Obj.tag nv);
  Obj.set_field v 0 (Obj.field nv 0);
  Obj.set_field v 1 (Obj.field nv 1)
	  
  

(******************************)

let normalize = function
  | String_latin1 (i,j,s,q) -> normalize_string_latin1 i j s q
  | String_utf8 (i,j,s,q) -> normalize_string_utf8 i j s q
  | Concat (_,_) as v -> eval_lazy_concat v; v
197
  | v -> v
198
199
200
201




202
203
204
205
206
207
let buf = Buffer.create 100

let rec add_buf_utf8_to_latin1 src i j =
  if Utf8.equal_index i j  then ()
  else
    let (c,i) = Utf8.next src i in
208
    if (c > 255) then failwith' "get_string_latin1";
209
210
211
    Buffer.add_char buf (Char.chr c);
    add_buf_utf8_to_latin1 src i j

212
213
214
let rec add_buf_latin1_to_utf8 src i j =
  for k = i to j - 1 do 
    Utf8.store buf (Char.code src.[k]) 
215
216
217
218
  done

let get_string_latin1 e =
  let rec aux = function
219
    | Pair (Char x,y) -> Buffer.add_char buf (Chars.V.to_char x); aux y
220
221
    | String_latin1 (i,j,src,y) -> Buffer.add_substring buf src i (j - i); aux y
    | String_utf8 (i,j,src,y) -> add_buf_utf8_to_latin1 src i j; aux y
222
    | Concat (_,_) as v -> eval_lazy_concat v; aux v
223
    | _ -> () in
224
  Buffer.clear buf;
225
226
227
228
229
230
231
  aux e;
  let s = Buffer.contents buf in
  Buffer.clear buf;
  s

let get_string_utf8 e =
  let rec aux = function
232
    | Pair (Char x,y) -> Utf8.store buf (Chars.V.to_int x); aux y
233
    | String_latin1 (i,j,src,y) -> add_buf_latin1_to_utf8 src i j; aux y
234
    | String_utf8 (i,j,src,y) -> Utf8.copy buf src i j; aux y
235
    | Concat (_,_) as v -> eval_lazy_concat v; aux v
236
237
    | q -> q in
  let q = aux e in
238
239
  let s = Buffer.contents buf in
  Buffer.clear buf;
240
  (Utf8.mk s, q)
241

242
let get_int = function
243
  | Integer i when Intervals.V.is_int i -> Intervals.V.get_int i
244
  | _ -> raise (Invalid_argument "Value.get_int")
245

246
247
248
249
let get_integer = function
  | Integer i -> i
  | _ -> assert false

250
251
252
let rec is_seq = function
  | Pair (_, y) when is_seq y -> true
  | Atom a when a = Sequence.nil_atom -> true
253
  | String_latin1 (_,_,_,y) | String_utf8 (_,_,_,y) when is_seq y  -> true
254
  | Concat (_,_) as v -> eval_lazy_concat v; is_seq v
255
256
257
  | _ -> false

let rec is_str = function
258
  | Pair (Char _, y) -> is_str y
259
  | Atom a when a = Sequence.nil_atom -> true
260
  | String_latin1 (_,_,_,q) | String_utf8(_,_,_,q) -> is_str q
261
  | Concat (_,_) as v -> eval_lazy_concat v; is_str v
262
263
264
  | _ -> false

let rec print ppf v =
265
266
267
268
269
270
  if is_str v then 
    (Format.fprintf ppf "\"";
     print_quoted_str ppf v;
     Format.fprintf ppf "\"")
  else if is_seq v then Format.fprintf ppf "[ @[<hv>%a@]]" print_seq v
  else  match v with
271
    | Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
272
    | Xml (x,y,z) | XmlNs (x,y,z,_) -> print_xml ppf x y z
273
    | Record l -> Format.fprintf ppf "@[{%a }@]" print_record (Imap.elements l)
274
275
276
    | Atom a ->	Atoms.V.print_quote ppf a
    | Integer i -> Intervals.V.print ppf i
    | Char c ->	Chars.V.print ppf c
277
    | Abstraction _ -> Format.fprintf ppf "<fun>"
278
279
280
281
282
    | String_latin1 (i,j,s,q) -> 
	Format.fprintf ppf "<string_latin1:%i-%i,%S,%a>" i j s print q
    | String_utf8 (i,j,s,q) -> 
	Format.fprintf ppf "<string_utf8:%i-%i,%S,%a>" 
	(Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q
283
284
    | Concat (x,y) ->
	Format.fprintf ppf "<concat:%a;%a>" print x print y
285
286
    | Abstract ("float",o) ->
	Format.fprintf ppf "%f" (Obj.magic o : float)
287
288
    | Abstract (s,_) ->
	Format.fprintf ppf "<abstract=%s>" s
289
290
    | Absent -> 	
	Format.fprintf ppf "<[absent]>"
291
and print_quoted_str ppf = function
292
  | Pair (Char c, q) -> 
293
      Chars.V.print_in_string ppf c; 
294
      print_quoted_str ppf q
295
  | String_latin1 (i,j,s, q) ->
296
      for k = i to j - 1 do
297
	Chars.V.print_in_string ppf (Chars.V.mk_char s.[k])
298
      done;
299
      print_quoted_str ppf q
300
  | String_utf8 (i,j,s, q) ->
301
302
303
304
305
(*      Format.fprintf ppf "UTF8:{"; *)
      let rec aux i =
	if Utf8.equal_index i j then q
	else 
	  let (c,i) =Utf8.next s i in
306
	  Chars.V.print_in_string ppf (Chars.V.mk_int c);
307
308
309
310
311
312
	  aux i
      in
      let q = aux i in
(*      Format.fprintf ppf "}"; *)
      print_quoted_str ppf q
  | q -> q
313
and print_seq ppf = function
314
  | (Pair(Char _, _)|String_latin1 (_,_,_,_)|String_utf8 (_,_,_,_)) as s ->
315
      Format.fprintf ppf "'";
316
317
318
319
320
321
      let q = print_quoted_str ppf s in
      Format.fprintf ppf "'@ ";
      print_seq ppf q
  | Pair (x,y) -> 
      Format.fprintf ppf "@[%a@]@ " print x;
      print_seq ppf y
322
323
  | _ -> ()

324
and print_xml ppf tag attr content =
325
326
327
328
329
330
331
332
333
334
  if is_seq content then
    Format.fprintf ppf "@[<hv2><%a%a>[@ %a@]]"
      print_tag tag
      print_attr attr
      print_seq content
  else
    Format.fprintf ppf "@[<hv2><%a%a>@ %a@]"
      print_tag tag
      print_attr attr
      print content
335
and print_tag ppf = function
336
  | Atom tag -> Atoms.V.print ppf tag
337
338
  | tag -> Format.fprintf ppf "(%a)" print tag
and print_attr ppf = function
339
  | Record attr -> print_record ppf (Imap.elements attr)
340
  | attr -> Format.fprintf ppf "(%a)" print attr
341
342
343

and print_record ppf = function
  | [] -> ()
344
  | f :: rem -> Format.fprintf ppf "@ %a" print_field f; print_record ppf rem
345
346

and print_field ppf (l,v) = 
347
  Format.fprintf ppf "%a=%a" Label.print_attr (Label.from_int l) print v  
348

349
350
351
352
353
let dump_xml ppf v =
  let rec aux ppf = function
    | Pair (x, y) ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<pair>@,%a@,%a@,</pair>@]" aux x aux y
354
    | Xml (x, y, z) | XmlNs (x,y,z,_) ->
355
356
357
358
359
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<xml>@,%a@,%a@,%a@,</xml>@]" aux x aux y aux z
    | Record x ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<record>@,%a@,</record>@]"
360
          (fun ppf x -> print_record ppf (Imap.elements x)) x
361
362
    | Atom a ->
        Format.fprintf ppf "@[<hv1>";
363
        Format.fprintf ppf "<atom>@,%a@,</atom>@]"
364
365
366
367
368
369
370
371
372
373
374
375
          (fun ppf x -> Atoms.V.print ppf x) a
    | Integer i ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<integer>@,%a@,</integer>@]"
          (fun ppf x -> Intervals.V.print ppf x) i
    | Char c ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<char>@,%a@,</char>@]"
          (fun ppf x -> Chars.V.print ppf x) c
    | Abstraction _ ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<abstraction />@]"
376
377
    | Abstract (s,_) ->
	Format.fprintf ppf "<abstract>%s</abstract>" s
378
379
    | String_latin1 (_, _, s, v) ->
        Format.fprintf ppf "@[<hv1>";
380
        Format.fprintf ppf "<string_latin1>@,%s@,</string_latin1>@," s;
381
382
383
384
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<follow>@,%a@,</follow>@]</string_latin1>@]" aux v
    | String_utf8 (_, _, s, v) ->
        Format.fprintf ppf "@[<hv1>";
385
386
        Format.fprintf ppf "<string_utf8>@,%s@,</string_utf8>@,"
          (Utf8.get_str s);
387
388
389
390
391
392
393
394
395
396
397
398
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<follow>@,%a@,</follow>@]</string_utf8>@]" aux v
    | Concat (x, y) ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<concat>@,%a@,%a@,</concat>@]" aux x aux y
    | Absent ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<absent />@]"
  in
  Format.fprintf ppf "@[<hv1>";
  Format.fprintf ppf "<value>@,%a@,</value>@]" aux v

399
400
401
402
let rec compare x y =
  if (x == y) then 0
  else
    match (x,y) with
403
      | Pair (x1,x2), Pair (y1,y2) ->
404
405
	  let c = compare x1 y1 in if c <> 0 then c 
	  else compare x2 y2	    
406
407
      | (Xml (x1,x2,x3) | XmlNs (x1,x2,x3,_)), 
	  (Xml (y1,y2,y3) | XmlNs(y1,y2,y3,_)) ->
408
	  let c = compare x1 y1 in if c <> 0 then c 
409
	  else let c = compare x2 y2 in if c <> 0 then c 
410
	  else compare x3 y3
411
      | Record rx, Record ry -> Imap.compare compare rx ry
412
413
414
      | Atom x, Atom y -> Atoms.V.compare x y
      | Integer x, Integer y -> Intervals.V.compare x y
      | Char x, Char y -> Chars.V.compare x y
415
      | Abstraction (_,_), _
416
      | _, Abstraction (_,_) ->
417
	  raise (CDuceExn (string_latin1 "comparing functional values"))
418
419
      | Abstract (s1,v1), Abstract (s2,v2) ->
	  let c = Types.Abstract.T.compare s1 s2 in if c <> 0 then c 
420
421
	  else Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float)
	    (* raise (CDuceExn (string_latin1 "comparing abstract values")) *)
422
423
424
425
      | Absent,_ | _,Absent ->
	  Format.fprintf Format.std_formatter
	    "ERR: Compare %a %a@." print x print y;
	  assert false
426
427
      | Concat (_,_) as x, y -> eval_lazy_concat x; compare x y
      | x, (Concat (_,_) as y) -> eval_lazy_concat y; compare x y
428
      | String_latin1 (ix,jx,sx,qx), String_latin1 (iy,jy,sy,qy) ->
429
430
431
432
433
434
435
	  if (sx == sy) && (ix = iy) && (jx = jy) then compare qx qy
	  else
	    (* Note: we would like to compare first jx-ix and jy-iy,
	       but this is not compatible with the equivalence of values *)
	    let rec aux ix iy =
	      if (ix = jx) then
		if (iy = jy) then compare qx qy
436
		else compare qx (normalize_string_latin1 iy jy sy qy)
437
	      else
438
		if (iy = jy) then compare (normalize_string_latin1 ix jx sx qx) qy
439
440
441
442
443
444
445
		else
		  let c1 = String.unsafe_get sx ix
		  and c2 = String.unsafe_get sy iy in
		  if c1 < c2 then -1 else
		    if c1 > c2 then 1 else aux (ix + 1) (iy + 1)
	    in
	    aux ix iy
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
      | String_utf8 (ix,jx,sx,qx), String_utf8 (iy,jy,sy,qy) ->
	  if (sx == sy) && (Utf8.equal_index ix iy) && (Utf8.equal_index jx jy) then compare qx qy
	  else
	    let rec aux ix iy =
	      if (Utf8.equal_index ix jx) then
		if (Utf8.equal_index iy jy) then compare qx qy
		else compare qx (normalize_string_utf8 iy jy sy qy)
	      else
		if (Utf8.equal_index iy jy) then compare (normalize_string_utf8 ix jx sx qx) qy
		else
		  let (c1,ix) = Utf8.next sx ix in
		  let (c2,iy) = Utf8.next sy iy in
		  if c1 < c2 then -1 else
		    if c1 > c2 then 1 else aux ix iy
	    in
	    aux ix iy
      | String_latin1 (i,j,s,q), _ -> compare (normalize_string_latin1 i j s q) y
      | _, String_latin1 (i,j,s,q) -> compare x (normalize_string_latin1 i j s q)
      | String_utf8 (i,j,s,q), _   -> compare (normalize_string_utf8 i j s q) y
      | _, String_utf8 (i,j,s,q)   -> compare x (normalize_string_utf8 i j s q)
466
467

      | Pair (_,_), _ -> -1 | _, Pair(_,_) -> 1
468
469
      | (Xml (_,_,_) | XmlNs (_,_,_,_)),_ -> -1 
      | _, (Xml(_,_,_) | XmlNs(_,_,_,_)) -> 1
470
471
472
      | Record _,_ -> -1 | _, Record _ -> 1
      | Atom _,_ -> -1 | _, Atom _ -> 1
      | Integer _,_ -> -1 | _, Integer _ -> 1
473
      | Abstract _, _ -> -1 | _, Abstract _ -> 1
474

475
476
let rec hash = function
  | Pair (x1,x2) ->
477
      1 + hash x1 * 257 + hash x2 * 17 
478
  | (Xml (x1,x2,x3) | XmlNs (x1,x2,x3,_)) ->
479
480
      2 + hash x1 * 65537 + hash x2 * 257 + hash x3 * 17
  | Record rx -> 
481
      3 + 17 * Imap.hash hash rx
482
483
484
485
486
487
  | Atom x -> 
      4 + 17 * Atoms.V.hash x
  | Integer x -> 
      5 + 17 * Intervals.V.hash x
  | Char x -> 
      6 + 17 * Chars.V.hash x
488
  | Abstraction _ -> 7
489
  | Abstract _ -> 8
490
491
492
493
494
  | Absent -> assert false
  | Concat _ as x -> eval_lazy_concat x; hash x
  | String_latin1 (i,j,s,q) -> hash (normalize_string_latin1 i j s q)
  | String_utf8 (i,j,s,q) ->hash (normalize_string_utf8 i j s q)

495
496
497
let iter_xml pcdata_callback other_callback =
  let rec aux = function
    | v when compare v nil = 0 -> ()
498
    | Pair (Char c, tl) ->
499
        pcdata_callback (U.mk_char (Chars.V.to_int c));
500
        aux tl
501
502
    | String_latin1 (i,j,s,tl) ->
        pcdata_callback (U.mk_latin1 (String.sub s i j));
503
        aux tl
504
    | String_utf8 (i,j,s,tl) ->
505
506
507
508
509
        pcdata_callback (U.mk (U.get_substr s i j));
        aux tl
    | Pair (hd, tl) ->
        other_callback hd;
        aux tl
510
    | Concat (_,_) as v -> eval_lazy_concat v; aux v
511
    | v -> raise (Invalid_argument "Value.iter_xml")
512
513
  in
  function
514
    | Xml (_,_,cont) | XmlNs (_,_,cont,_) -> aux cont
515
    | _ -> raise (Invalid_argument "Value.iter_xml")
516

517
(*
518
519
520
521
522
523
let map_xml map_pcdata map_other =
  let patch_string_utf8 cont = function
    | String_utf8 (i, j, u, v) when compare v nil = 0 ->
        String_utf8 (i, j, u, cont)
    | _ -> assert false
  in
524
525
526
527
528
  let rec aux v =
    match v with
    | Pair (Char _, _) | String_latin1 _ | String_utf8 _ ->
        let (u, rest) = get_string_utf8 v in
        patch_string_utf8 (aux rest) (string_utf8 (map_pcdata u))
529
530
531
532
533
534
535
536
    | Pair (hd, tl) -> Pair (map_other hd, aux tl)
    | Concat (_,_) as v -> eval_lazy_concat v; aux v
    | v when compare v nil = 0 -> v
    | v -> raise (Invalid_argument "Value.map_xml")
  in
  function
    | Xml (tag,attrs,cont) -> Xml (tag, attrs, aux cont)
    | _ -> raise (Invalid_argument "Value.map_xml")
537
*)
538
539
540

let tagged_tuple tag vl =
  let ct = sequence vl in
541
  let at = Record Imap.empty in
542
543
544
  let tag = Atom (Atoms.V.mk_ascii tag) in
  Xml (tag, at, ct)

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
  (** set of values *)

type tmp = t
module OrderedValue =
  struct
    type t = tmp
    let compare = compare
  end
module ValueSet = Set.Make(OrderedValue)

let ( |<| ) x y = compare x y < 0
let ( |>| ) x y = compare x y > 0
let ( |<=| ) x y = let c = compare x y in c < 0 || c = 0
let ( |>=| ) x y = let c = compare x y in c > 0 || c = 0
let ( |=| ) x y = compare x y = 0
560
let equal = ( |=| )
561
let ( |<>| ) x y = compare x y <> 0
562

563
564
565
566
567
568
(*
let rec concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, concat y l2)
  | String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, concat q l2)
  | String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, concat q l2)
  | q -> l2
569

570
571
572
let rec flatten = function
  | Pair (x,y) -> concat x (flatten y)
  | q -> q
573

574
*)
575
576


577
let () = dump_forward := dump_xml
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597

let get_pair v =
  match normalize v with
    | Pair (x,y) -> (x,y)
    | _ -> assert false

(* TODO: tail-rec version of get_sequence *)

let rec get_sequence v =
  match normalize v with
    | Pair (x,y) -> x :: (get_sequence y)
    | _ -> []

let rec get_sequence_rev accu v =
  match normalize v with
    | Pair (x,y) -> get_sequence_rev (x::accu) y
    | _ -> accu

let get_sequence_rev v = get_sequence_rev [] v

598
599
600
601
602
let rec fold_sequence f accu v =
  match normalize v with
    | Pair (x,y) -> fold_sequence f (f accu x) y
    | _ -> accu

603
604
605
606
607
608
609
610
611
612
let atom_ascii s =
  Atom (Atoms.V.mk_ascii s)

let get_variant = function
  | Atom a -> Atoms.V.get_ascii a, None
  | v -> match normalize v with
      | Pair (Atom a,x) -> Atoms.V.get_ascii a, Some x
      | _ -> assert false

let label_ascii s =
613
  Label.mk_ascii s
614

615
616
let record (l : (label * t) list) =
  Record (Imap.create (Array.of_list (Obj.magic l)))
617

618
619
620
let record_ascii l =
  record (List.map (fun (l,v) -> (label_ascii l, v)) l)

621
622
623

let get_field v l =
  match v with
624
    | Record fields -> Imap.find fields (Upool.int l)
625
    | _ -> raise Not_found
626

627
628
let get_field_ascii v l = get_field v (label_ascii l)

629
630
631
632
633
634
635
let abstract a v =
  Abstract (a,Obj.repr v)

let get_abstract = function
  | Abstract (_,v) -> Obj.magic v
  | _ -> assert false
  
636

637
638
let get_label = Upool.int (label_ascii "get")
let set_label = Upool.int (label_ascii "set")
639
let mk_rf ~get ~set =
640
  Imap.create [| get_label, get; set_label, set |]
641

642
643
let mk_ref t v =
  let r = ref v in
644
645
  let get = Abstraction (Some [Sequence.nil_type, t], fun _ -> !r)
  and set = Abstraction (Some [t, Sequence.nil_type], fun x -> r := x; nil) in
646
  Record (mk_rf ~get ~set)
647
648
649


let mk_ext_ref t get set =
650
651
652
653
654
655
  let get = Abstraction (
    (match t with Some t -> Some [Sequence.nil_type, t] | None -> None),
    fun _ -> get ())
  and set = Abstraction (
    (match t with Some t -> Some [t, Sequence.nil_type] | None -> None), 
    fun v -> set v; nil) in
656
  Record (mk_rf ~get ~set)
657
  
658
659
660
661
662
663
664
665

let ocaml2cduce_int i =
  Integer (Intervals.V.from_int i)

let cduce2ocaml_int = function
  | Integer i -> Intervals.V.get_int i
  | _ -> assert false

666
667
668
669
670
671
672
673
674
675
676
677
678
679
let ocaml2cduce_int32 i =
  Integer (Intervals.V.from_int32 i)

let cduce2ocaml_int32 = function
  | Integer i -> Intervals.V.to_int32 i
  | _ -> assert false

let ocaml2cduce_int64 i =
  Integer (Intervals.V.from_int64 i)

let cduce2ocaml_int64 = function
  | Integer i -> Intervals.V.to_int64 i
  | _ -> assert false

680
let ocaml2cduce_string s = string_latin1 (String.copy s)
681

682
let cduce2ocaml_string = get_string_latin1 (* Result is already fresh *)
683

684
let ocaml2cduce_string_utf8 s = string_utf8 (U.mk (String.copy (U.get_str s)))
685

686
let cduce2ocaml_string_utf8 s = fst (get_string_utf8 s) (* Result is already fresh *)
687

688
689
690
let ocaml2cduce_char c =
  Char (Chars.V.mk_char c)

691
692
693
let ocaml2cduce_wchar c =
  Char (Chars.V.mk_int c)

694
695
696
let cduce2ocaml_char = function
  | Char c -> Chars.V.to_char c 
  | _ -> assert false
697

698
699
700
701
702
703
let ocaml2cduce_bigint i =
  Integer (Intervals.V.from_bigint i)

let cduce2ocaml_bigint = function
  | Integer i -> Intervals.V.get_bigint i
  | _ -> assert false
704

705
706
let ocaml2cduce_atom q = Atom q
let cduce2ocaml_atom = function Atom a -> a | _ -> assert false
707
708
709
710

let print_utf8 v =
  print_string (U.get_str v);
  flush stdout
711

712
713

let float n =
714
  Abstract ("float", Obj.repr n)
715
716
717
718
719
720
721
722
723
724
725
726
727

let cduce2ocaml_option f v =
  match normalize v with
    | Pair (x,y) -> Some (f x)
    | _ -> None


let ocaml2cduce_option f = function
  | Some x -> Pair (f x, nil)
  | None -> nil



728
729
let add v1 v2 = match (v1,v2) with
  | (Integer x, Integer y) -> Integer (Intervals.V.add x y)
730
  | (Record r1, Record r2) -> Record (Imap.merge r1 r2)
731
732
  | _ -> assert false

733
let merge v1 v2 = match (v1,v2) with
734
  | (Record r1, Record r2) -> Record (Imap.merge r1 r2)
735
736
  | _ -> assert false

737
738
739
740
let sub v1 v2 = match (v1,v2) with
  | (Integer x, Integer y) -> Integer (Intervals.V.sub x y)
  | _ -> assert false

741
742
743
744
745
746
747
748
let mul v1 v2 = match (v1,v2) with
  | (Integer x, Integer y) -> Integer (Intervals.V.mult x y)
  | _ -> assert false

let div v1 v2 = match (v1,v2) with
  | (Integer x, Integer y) -> Integer (Intervals.V.div x y)
  | _ -> assert false

749
750
751
752
let modulo v1 v2 = match (v1,v2) with
  | (Integer x, Integer y) -> Integer (Intervals.V.modulo x y)
  | _ -> assert false

753

754
755
756
757
758
759
760
let pair v1 v2 = Pair (v1,v2)
let xml v1 v2 v3 = Xml (v1,v2,v3)

let mk_record labels fields =
  let l = ref [] in
  assert (Array.length labels == Array.length fields);
  for i = 0 to Array.length labels - 1 do
761
    l := (labels.(i),fields.(i)) :: !l;
762
  done;
763
  record !l
764
  
765

766
767
768
769
(* TODO: optimize cases
     - (f x = [])
     - all chars copied or deleted *)

770
let rec transform_aux f accu = function
771
  | Pair (x,y) -> let accu = concat accu (f x) in transform_aux f accu y
772
773
774
775
  | Atom _ -> accu
  | v -> transform_aux f accu (normalize v)

let transform f v = transform_aux f nil v
776

777
778
779
780
781
782
783
784
785
786
787
788
789

let rec xtransform_aux f accu = function
  | Pair (x,y) -> 
      let accu = match f x with
	| Absent ->
	    let x = match x with
	      | Xml (tag, attr, child) -> 
		  let child = xtransform_aux f nil child in
		  Xml (tag, attr, child)
	      | XmlNs (tag, attr, child, ns) ->
		  let child = xtransform_aux f nil child in
		  XmlNs (tag, attr, child, ns)
	      | x -> x in
790
791
	    concat accu (Pair (x,nil))
	| x -> concat accu x
792
793
794
795
796
797
798
      in 
      xtransform_aux f accu y
  | Atom _ -> accu
  | v -> xtransform_aux f accu (normalize v)

let xtransform f v = xtransform_aux f nil v

799
let remove_field l = function
800
  | Record r -> Record (Imap.remove r (Upool.int l))
801
  | _ -> assert false
802
803
804
805
806

let rec ocaml2cduce_list f = function
  | [] -> nil
  | hd::tl -> Pair (f hd, ocaml2cduce_list f tl)

807
808
let rec cduce2ocaml_list f v =
  match normalize v with
809
    | Pair (x,y) -> f x :: (cduce2ocaml_list f y)
810
811
    | _ -> []

812
813
814
let ocaml2cduce_array f x = ocaml2cduce_list f (Array.to_list x)
let cduce2ocaml_array f x = Array.of_list (cduce2ocaml_list f x)

815
let no_attr = Record Imap.empty
816

817
818
let ocaml2cduce_constr tag va = 
  Xml (tag, no_attr, sequence_of_array va)
819

820
let rec cduce2ocaml_constr m = function
821
822
823
824
  | Atom q ->
      Obj.repr (Atoms.get_map q m)
  | Xml (Atom q,_,f) | XmlNs (Atom q,_,f,_) ->
	let tag = Atoms.get_map q m in
825
826
827
	let x = Obj.repr (Array.of_list (get_sequence f)) in
	Obj.set_tag x tag;
	x
828
  | _ -> assert false
829

830
let rec cduce2ocaml_variant m = function
831
832
833
834
  | Atom q ->
      Obj.repr (Atoms.get_map q m)
  | Xml (Atom q,_,f) | XmlNs (Atom q,_,f,_) ->
	let tag = Atoms.get_map q m in
835
836
837
838
	let (x,_) = get_pair f in
	Obj.repr (tag,x)
  | _ -> assert false

839
      
840
841
842
843
844
845
846
847
848
849
let ocaml2cduce_fun farg fres f =
  Abstraction (None, fun x -> fres (f (farg x)))

let cduce2ocaml_fun farg fres = function
  | Abstraction (_, f) -> (fun x -> fres (f (farg x)))
  | _ -> assert false

let apply f arg = match f with
  | Abstraction (_,f) -> f arg
  | _ -> assert false
850
851
852
853
854
855
856
857
858
859
860


type pools = Ns.Uri.value array * Ns.Label.value array

let extract_all () =
  Ns.Uri.extract (),
  Ns.Label.extract ()
 
let intract_all (uri,label) =
  Ns.Uri.intract uri;
  Ns.Label.intract label