value.ml 19.6 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
  | Record of t label_map
8
9
10
  | Atom of Atoms.V.t
  | Integer of Intervals.V.t
  | Char of Chars.V.t
11
  | Abstraction of (Types.descr * Types.descr) list * (t -> t)
12
  | Abstraction2 of t array * (Types.t * Types.t) list * Lambda.branches
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
  | Delayed of t ref

21
22
23
24
25
26
(* 
  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)
27

28
29
exception CDuceExn of t

30
let nil = Atom Sequence.nil_atom
31
32
33
34
35
36
37
38
39
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)
40
41
let vtrue = Atom (Atoms.V.mk_ascii "true")
let vfalse = Atom (Atoms.V.mk_ascii "false")
42
43
let vbool x = if x then vtrue else vfalse

44
let vrecord l =
45
  let l = List.map (fun (qname,v) -> LabelPool.mk qname, v) l in
46
  Record (LabelMap.from_list_disj l)
47
48

let get_fields = function
49
  | Record map -> LabelMap.mapi_to_list (fun k v -> LabelPool.value k, v) map
50
  | _ -> raise (Invalid_argument "Value.get_fields")
51

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

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

let sequence_rev l = sequence_rev nil l

62
63
64
65
let concat v1 v2 = 
  match (v1,v2) with
    | (Atom _, v) | (v, Atom _) -> v
    | (v1,v2) -> Concat (v1,v2)
66

67
68
69
let failwith' s = raise (CDuceExn (string_latin1 s))
let raise' v = raise (CDuceExn v)

70

71
let rec const = function
72
73
74
  | Types.Integer i -> Integer i
  | Types.Atom a -> Atom a
  | Types.Char c -> Char c
75
76
77
78
79
80
  | 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
  | Types.Record x -> Record (LabelMap.map const x)
  | Types.String (i,j,s,c) -> String_utf8 (i,j,s, const c)

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
let rec inv_const = function
  | Pair (x, y) -> Types.Pair (inv_const x, inv_const y)
  | Xml (x, y, z) ->
      Types.Pair (inv_const x, Types.Pair (inv_const y, inv_const z))
  | Record x -> Types.Record (LabelMap.map inv_const x)
  | 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"
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
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

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
178
  | v -> v
179
180
181
182




183
184
185
186
187
188
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
189
    if (c > 255) then failwith' "get_string_latin1";
190
191
192
    Buffer.add_char buf (Char.chr c);
    add_buf_utf8_to_latin1 src i j

193
194
195
let rec add_buf_latin1_to_utf8 src i j =
  for k = i to j - 1 do 
    Utf8.store buf (Char.code src.[k]) 
196
197
198
199
  done

let get_string_latin1 e =
  let rec aux = function
200
    | Pair (Char x,y) -> Buffer.add_char buf (Chars.V.to_char x); aux y
201
202
    | 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
203
    | Concat (_,_) as v -> eval_lazy_concat v; aux v
204
    | _ -> () in
205
  Buffer.clear buf;
206
207
208
209
210
211
212
  aux e;
  let s = Buffer.contents buf in
  Buffer.clear buf;
  s

let get_string_utf8 e =
  let rec aux = function
213
    | Pair (Char x,y) -> Utf8.store buf (Chars.V.to_int x); aux y
214
    | String_latin1 (i,j,src,y) -> add_buf_latin1_to_utf8 src i j; aux y
215
    | String_utf8 (i,j,src,y) -> Utf8.copy buf src i j; aux y
216
    | Concat (_,_) as v -> eval_lazy_concat v; aux v
217
218
    | q -> q in
  let q = aux e in
219
220
  let s = Buffer.contents buf in
  Buffer.clear buf;
221
  (Utf8.mk s, q)
222

223
let get_int = function
224
  | Integer i when Intervals.V.is_int i -> Intervals.V.get_int i
225
  | _ -> raise (Invalid_argument "Value.get_int")
226

227
228
229
let rec is_seq = function
  | Pair (_, y) when is_seq y -> true
  | Atom a when a = Sequence.nil_atom -> true
230
  | String_latin1 (_,_,_,y) | String_utf8 (_,_,_,y) when is_seq y  -> true
231
  | Concat (_,_) as v -> eval_lazy_concat v; is_seq v
232
233
234
  | _ -> false

let rec is_str = function
235
  | Pair (Char _, y) -> is_str y
236
  | Atom a when a = Sequence.nil_atom -> true
237
  | String_latin1 (_,_,_,q) | String_utf8(_,_,_,q) -> is_str q
238
  | Concat (_,_) as v -> eval_lazy_concat v; is_str v
239
240
241
  | _ -> false

let rec print ppf v =
242
243
244
245
246
247
  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
248
    | Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
249
    | Xml (x,y,z)  -> print_xml ppf x y z
250
    | Record l -> Format.fprintf ppf "{%a }" print_record (LabelMap.get l)
251
252
253
    | Atom a ->	Atoms.V.print_quote ppf a
    | Integer i -> Intervals.V.print ppf i
    | Char c ->	Chars.V.print ppf c
254
    | Abstraction _ -> Format.fprintf ppf "<fun>"
255
    | Abstraction2 _ -> Format.fprintf ppf "<fun>"
256
257
258
259
260
    | 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
261
262
    | Concat (x,y) ->
	Format.fprintf ppf "<concat:%a;%a>" print x print y
263
264
    | Abstract (s,_) ->
	Format.fprintf ppf "<abstract=%s>" s
265
266
    | Absent -> 	
	Format.fprintf ppf "<[absent]>"
267
268
    | Delayed x ->
	Format.fprintf ppf "<[delayed]>"
269
and print_quoted_str ppf = function
270
  | Pair (Char c, q) -> 
271
      Chars.V.print_in_string ppf c; 
272
      print_quoted_str ppf q
273
  | String_latin1 (i,j,s, q) ->
274
      for k = i to j - 1 do
275
	Chars.V.print_in_string ppf (Chars.V.mk_char s.[k])
276
      done;
277
      print_quoted_str ppf q
278
  | String_utf8 (i,j,s, q) ->
279
280
281
282
283
(*      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
284
	  Chars.V.print_in_string ppf (Chars.V.mk_int c);
285
286
287
288
289
290
	  aux i
      in
      let q = aux i in
(*      Format.fprintf ppf "}"; *)
      print_quoted_str ppf q
  | q -> q
291
and print_seq ppf = function
292
  | (Pair(Char _, _)|String_latin1 (_,_,_,_)|String_utf8 (_,_,_,_)) as s ->
293
      Format.fprintf ppf "'";
294
295
296
297
298
299
      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
300
301
  | _ -> ()

302
and print_xml ppf tag attr content =
303
304
305
306
307
308
309
310
311
312
  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
313
and print_tag ppf = function
314
  | Atom tag -> Atoms.V.print ppf tag
315
316
317
318
  | tag -> Format.fprintf ppf "(%a)" print tag
and print_attr ppf = function
  | Record attr -> print_record ppf (LabelMap.get attr)
  | attr -> Format.fprintf ppf "(%a)" print attr
319
320
321

and print_record ppf = function
  | [] -> ()
322
323
  | [f] -> Format.fprintf ppf " %a" print_field f
  | f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
324
325

and print_field ppf (l,v) = 
326
  Format.fprintf ppf "%a=%a" Label.print (LabelPool.value l) print v  
327

328
329
330
331
332
333
334
335
336
337
338
339
340
341
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
    | Xml (x, y, z) ->
        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>@]"
          (fun ppf x -> print_record ppf (LabelMap.get x)) x
    | Atom a ->
        Format.fprintf ppf "@[<hv1>";
342
        Format.fprintf ppf "<atom>@,%a@,</atom>@]"
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
          (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 />@]"
    | Abstraction2 _ ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<abstraction2 />@]"
358
359
    | Abstract (s,_) ->
	Format.fprintf ppf "<abstract>%s</abstract>" s
360
361
    | String_latin1 (_, _, s, v) ->
        Format.fprintf ppf "@[<hv1>";
362
        Format.fprintf ppf "<string_latin1>@,%s@,</string_latin1>@," s;
363
364
365
366
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<follow>@,%a@,</follow>@]</string_latin1>@]" aux v
    | String_utf8 (_, _, s, v) ->
        Format.fprintf ppf "@[<hv1>";
367
368
        Format.fprintf ppf "<string_utf8>@,%s@,</string_utf8>@,"
          (Utf8.get_str s);
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
        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 />@]"
    | Delayed _ ->
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<delayed />@]"
  in
  Format.fprintf ppf "@[<hv1>";
  Format.fprintf ppf "<value>@,%a@,</value>@]" aux v

384
385
386
387
let rec compare x y =
  if (x == y) then 0
  else
    match (x,y) with
388
      | Pair (x1,x2), Pair (y1,y2) ->
389
390
	  let c = compare x1 y1 in if c <> 0 then c 
	  else compare x2 y2	    
391
392
      | Xml (x1,x2,x3), Xml (y1,y2,y3) ->
	  let c = compare x1 y1 in if c <> 0 then c 
393
	  else let c = compare x2 y2 in if c <> 0 then c 
394
	  else compare x3 y3
395
      | Record rx, Record ry -> LabelMap.compare compare rx ry
396
397
398
      | 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
399
      | Abstraction (_,_), _
400
      | _, Abstraction (_,_)
401
402
403
      | Abstraction2 (_,_,_), _
      | _, Abstraction2 (_,_,_) -> 
	  raise (CDuceExn (string_latin1 "comparing functional values"))
404
405
      | Abstract (s1,v1), Abstract (s2,v2) ->
	  let c = Types.Abstract.T.compare s1 s2 in if c <> 0 then c 
406
	  else raise (CDuceExn (string_latin1 "comparing abstract values"))
407
408
      | Absent,_ | _,Absent 
      | Delayed _, _ | _, Delayed _ -> assert false
409
410
      | Concat (_,_) as x, y -> eval_lazy_concat x; compare x y
      | x, (Concat (_,_) as y) -> eval_lazy_concat y; compare x y
411
      | String_latin1 (ix,jx,sx,qx), String_latin1 (iy,jy,sy,qy) ->
412
413
414
415
416
417
418
	  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
419
		else compare qx (normalize_string_latin1 iy jy sy qy)
420
	      else
421
		if (iy = jy) then compare (normalize_string_latin1 ix jx sx qx) qy
422
423
424
425
426
427
428
		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
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
      | 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)
449
450
451
452
453
454

      | Pair (_,_), _ -> -1 | _, Pair(_,_) -> 1
      | Xml (_,_,_),_ -> -1 | _, Xml(_,_,_) -> 1
      | Record _,_ -> -1 | _, Record _ -> 1
      | Atom _,_ -> -1 | _, Atom _ -> 1
      | Integer _,_ -> -1 | _, Integer _ -> 1
455
      | Abstract _, _ -> -1 | _, Abstract _ -> 1
456

457
458
459
let iter_xml pcdata_callback other_callback =
  let rec aux = function
    | v when compare v nil = 0 -> ()
460
    | Pair (Char c, tl) ->
461
        pcdata_callback (U.mk_char (Chars.V.to_int c));
462
        aux tl
463
464
    | String_latin1 (i,j,s,tl) ->
        pcdata_callback (U.mk_latin1 (String.sub s i j));
465
        aux tl
466
    | String_utf8 (i,j,s,tl) ->
467
468
469
470
471
        pcdata_callback (U.mk (U.get_substr s i j));
        aux tl
    | Pair (hd, tl) ->
        other_callback hd;
        aux tl
472
    | Concat (_,_) as v -> eval_lazy_concat v; aux v
473
    | v -> raise (Invalid_argument "Value.iter_xml")
474
475
476
477
  in
  function
    | Xml (_,_,cont) -> aux cont
    | _ -> raise (Invalid_argument "Value.iter_xml")
478

479
480
481
482
483
484
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
485
486
487
488
489
  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))
490
491
492
493
494
495
496
497
    | 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")
498

499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
  (** 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
514
let equal = ( |=| )
515
let ( |<>| ) x y = compare x y <> 0
516

517
518
519
520
521
522
(*
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
523

524
525
526
let rec flatten = function
  | Pair (x,y) -> concat x (flatten y)
  | q -> q
527

528
*)
529
530


531
let () = dump_forward := dump_xml
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572

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

  
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 =
  LabelPool.mk (Ns.empty, U.mk s)

let record l =
  Record (LabelMap.from_list_disj l)


let get_field v l =
  match v with
    | Record fields -> LabelMap.assoc l fields
    | _ -> raise Not_found
573

574
575
576
577
578
579
580
let abstract a v =
  Abstract (a,Obj.repr v)

let get_abstract = function
  | Abstract (_,v) -> Obj.magic v
  | _ -> assert false
  
581
582
583
584
585
586
587
588
589
590
591
592
593

let mk_ref t v =
  let r = ref v in
  let get = Abstraction ([Sequence.nil_type, t], fun _ -> !r)
  and set = Abstraction ([t, Sequence.nil_type], fun x -> r := x; nil) in
  Record (Builtin_defs.mk_ref ~get ~set)


let mk_ext_ref t get set =
  let get = Abstraction ([Sequence.nil_type, t], fun _ -> get ())
  and set = Abstraction ([t, Sequence.nil_type], fun v -> set v; nil) in
  Record (Builtin_defs.mk_ref ~get ~set)
  
594
595
596
597
598
599
600
601
602
603
604
605

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

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

let ocaml2cduce_string = string_latin1

let cduce2ocaml_string = get_string_latin1

606
607
608
609
let ocaml2cduce_string_utf8 = string_utf8

let cduce2ocaml_string_utf8 s = fst (get_string_utf8 s)

610
611
612
613
614
615
let ocaml2cduce_char c =
  Char (Chars.V.mk_char c)

let cduce2ocaml_char = function
  | Char c -> Chars.V.to_char c 
  | _ -> assert false
616

617
618
619
620
621
622
let ocaml2cduce_bigint i =
  Integer (Intervals.V.from_bigint i)

let cduce2ocaml_bigint = function
  | Integer i -> Intervals.V.get_bigint i
  | _ -> assert false
623
624
625
626

let print_utf8 v =
  print_string (U.get_str v);
  flush stdout
627
628
629
630
631
632
633
634
635
636

let query_min = function
  | Pair(Integer i,p) -> 
       let rec aux l i  = match l with
   	 | Pair(Integer j,r)  -> if (compare (Integer i) (Integer
                              j) <0) then aux r i  else aux r j
         | Atom(_) -> Integer i
	 | _ -> assert false
       in aux p i 
  |_ -> assert false
637
638
639
640
641
642
643
644
645
let query_max = function
  | Pair(Integer i,p) -> 
       let rec aux l i  = match l with
   	 | Pair(Integer j,r)  -> if (compare (Integer i) (Integer
                              j) >0) then aux r i  else aux r j
         | Atom(_) -> Integer i
	 | _ -> assert false
       in aux p i 
  |_ -> assert false