value.ml 19.4 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
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 (qname,v) -> LabelPool.mk qname, v) l in
44
  Record (LabelMap.from_list_disj l)
45
46

let get_fields = function
47
  | Record map -> LabelMap.mapi_to_list (fun k v -> LabelPool.value k, v) 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
let concat v1 v2 = 
  match (v1,v2) with
    | (Atom _, v) | (v, Atom _) -> v
    | (v1,v2) -> Concat (v1,v2)
64

65
66
67
let append v1 v2 =
  concat v1 (Pair (v2,nil))

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

71

72
let rec const = function
73
74
75
  | Types.Integer i -> Integer i
  | Types.Atom a -> Atom a
  | Types.Char c -> Char c
76
77
78
79
80
81
  | 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)

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
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"
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
178

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




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

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

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

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

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

228
229
230
231
let get_integer = function
  | Integer i -> i
  | _ -> assert false

232
233
234
let rec is_seq = function
  | Pair (_, y) when is_seq y -> true
  | Atom a when a = Sequence.nil_atom -> true
235
  | String_latin1 (_,_,_,y) | String_utf8 (_,_,_,y) when is_seq y  -> true
236
  | Concat (_,_) as v -> eval_lazy_concat v; is_seq v
237
238
239
  | _ -> false

let rec is_str = function
240
  | Pair (Char _, y) -> is_str y
241
  | Atom a when a = Sequence.nil_atom -> true
242
  | String_latin1 (_,_,_,q) | String_utf8(_,_,_,q) -> is_str q
243
  | Concat (_,_) as v -> eval_lazy_concat v; is_str v
244
245
246
  | _ -> false

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

305
and print_xml ppf tag attr content =
306
307
308
309
310
311
312
313
314
315
  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
316
and print_tag ppf = function
317
  | Atom tag -> Atoms.V.print ppf tag
318
319
320
321
  | 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
322
323
324

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

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

331
332
333
334
335
336
337
338
339
340
341
342
343
344
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>";
345
        Format.fprintf ppf "<atom>@,%a@,</atom>@]"
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
          (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 />@]"
361
362
    | Abstract (s,_) ->
	Format.fprintf ppf "<abstract>%s</abstract>" s
363
364
    | String_latin1 (_, _, s, v) ->
        Format.fprintf ppf "@[<hv1>";
365
        Format.fprintf ppf "<string_latin1>@,%s@,</string_latin1>@," s;
366
367
368
369
        Format.fprintf ppf "@[<hv1>";
        Format.fprintf ppf "<follow>@,%a@,</follow>@]</string_latin1>@]" aux v
    | String_utf8 (_, _, s, v) ->
        Format.fprintf ppf "@[<hv1>";
370
371
        Format.fprintf ppf "<string_utf8>@,%s@,</string_utf8>@,"
          (Utf8.get_str s);
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 />@]"
  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
409
410
      | Absent,_ | _,Absent ->
	  Format.fprintf Format.std_formatter
	    "ERR: Compare %a %a@." print x print y;
	  assert false
411
412
      | Concat (_,_) as x, y -> eval_lazy_concat x; compare x y
      | x, (Concat (_,_) as y) -> eval_lazy_concat y; compare x y
413
      | String_latin1 (ix,jx,sx,qx), String_latin1 (iy,jy,sy,qy) ->
414
415
416
417
418
419
420
	  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
421
		else compare qx (normalize_string_latin1 iy jy sy qy)
422
	      else
423
		if (iy = jy) then compare (normalize_string_latin1 ix jx sx qx) qy
424
425
426
427
428
429
430
		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
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
      | 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)
451
452
453
454
455
456

      | Pair (_,_), _ -> -1 | _, Pair(_,_) -> 1
      | Xml (_,_,_),_ -> -1 | _, Xml(_,_,_) -> 1
      | Record _,_ -> -1 | _, Record _ -> 1
      | Atom _,_ -> -1 | _, Atom _ -> 1
      | Integer _,_ -> -1 | _, Integer _ -> 1
457
      | Abstract _, _ -> -1 | _, Abstract _ -> 1
458

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

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

501
502
503
504
505
506
507

let tagged_tuple tag vl =
  let ct = sequence vl in
  let at = Record LabelMap.empty in
  let tag = Atom (Atoms.V.mk_ascii tag) in
  Xml (tag, at, ct)

508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
  (** 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
523
let equal = ( |=| )
524
let ( |<>| ) x y = compare x y <> 0
525

526
527
528
529
530
531
(*
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
532

533
534
535
let rec flatten = function
  | Pair (x,y) -> concat x (flatten y)
  | q -> q
536

537
*)
538
539


540
let () = dump_forward := dump_xml
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560

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

561
562
563
564
565
let rec fold_sequence f accu v =
  match normalize v with
    | Pair (x,y) -> fold_sequence f (f accu x) y
    | _ -> accu

566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
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)

581
582
583
let record_ascii l =
  record (List.map (fun (l,v) -> (label_ascii l, v)) l)

584
585
586
587
588

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

590
591
let get_field_ascii v l = get_field v (label_ascii l)

592
593
594
595
596
597
598
let abstract a v =
  Abstract (a,Obj.repr v)

let get_abstract = function
  | Abstract (_,v) -> Obj.magic v
  | _ -> assert false
  
599
600
601
602
603
604
605
606
607
608
609
610
611

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)
  
612
613
614
615
616
617
618
619
620
621
622
623

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

624
625
626
627
let ocaml2cduce_string_utf8 = string_utf8

let cduce2ocaml_string_utf8 s = fst (get_string_utf8 s)

628
629
630
631
632
633
let ocaml2cduce_char c =
  Char (Chars.V.mk_char c)

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

635
636
637
638
639
640
let ocaml2cduce_bigint i =
  Integer (Intervals.V.from_bigint i)

let cduce2ocaml_bigint = function
  | Integer i -> Intervals.V.get_bigint i
  | _ -> assert false
641
642
643
644

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