Commit d774a55b authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Partial fix for issue #20. In the Value.t type, the Concat _ value and the...

Partial fix for issue #20. In the Value.t type, the Concat _ value and the Pair value must have the same underlying representation (since their tag is mutated).
This actually also corrects a bug: Concat _ nodes acts as constructor (like pairs, xml, records, …) and should also be decorated with a sigma. Adding a sigma component to Concat make the segfault disapear. However, for the moment substitutions in Concat are never used.
parent 8a032b4e
......@@ -15,8 +15,8 @@ let make_accu () = Value.Pair(nil,Absent,Value.Mono)
let get_accu a = snd (Obj.magic a)
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
let rec ensure a i =
let n = Array.length !a in
let rec ensure a i =
let n = Array.length !a in
if i >= n then (
let b = Array.create (max (n*2) i) Value.Absent in
Array.blit !a 0 b 0 n;
......@@ -69,7 +69,7 @@ let pp_lambda_env ppf env locals =
let sl = List.mapi (fun i v ->
Format.fprintf Format.str_formatter "%d : %a@." i Value.Print.pp_value v;
Format.flush_str_formatter ()
) l
) l
in
String.concat "," sl
in
......@@ -104,11 +104,11 @@ let rec eval env locals = function
| TVar (x,sigma) -> (* delayed sigma application *)
let sigma' = eval_sigma env locals sigma in
apply_sigma sigma' (eval_var env locals x)
| Apply (e1,e2) ->
| Apply (e1,e2) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
eval_apply v1 v2
| PolyAbstraction (slots,iface,body,lsize,sigma) ->
| PolyAbstraction (slots,iface,body,lsize,sigma) ->
let sigma' = eval_sigma env locals sigma in
eval_abstraction env locals slots iface body lsize sigma'
| Abstraction (slots,iface,body,lsize) ->
......@@ -120,17 +120,17 @@ let rec eval env locals = function
(* This is the empty substitution. sigma is associated to a pair only
* when is from a variable x_sigma *)
Value.Pair (v1,v2,Value.Mono)
| Xml (e1,e2,e3) ->
| Xml (e1,e2,e3) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
let v3 = eval env locals e3 in
Value.Xml (v1,v2,v3,Value.Mono)
| XmlNs (e1,e2,e3,ns) ->
| XmlNs (e1,e2,e3,ns) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
let v3 = eval env locals e3 in
Value.XmlNs (v1,v2,v3,ns,Value.Mono)
| Record r ->
| Record r ->
Value.Record (Imap.map (eval env locals) r, Value.Mono)
| String (i,j,s,q) -> Value.substring_utf8 i j s (eval env locals q)
(* let is encoded as a match *)
......@@ -138,12 +138,12 @@ let rec eval env locals = function
| Map (arg,brs) -> eval_map env locals brs (eval env locals arg)
| Xtrans (arg,brs) -> eval_xtrans env locals brs (eval env locals arg)
| Try (arg,brs) -> eval_try env locals arg brs
| Transform (arg,brs) -> eval_transform env locals brs (eval env locals arg)
| Transform (arg,brs) -> eval_transform env locals brs (eval env locals arg)
| Dot (e, l) -> eval_dot l (eval env locals e)
| RemoveField (e, l) -> eval_remove_field l (eval env locals e)
| Validate (e, v) -> eval_validate env locals e v
| Ref (e,t) -> eval_ref env locals e t
| Op (op,args) as e ->
| Op (op,args) as e ->
let eval_fun = eval_op op in
Obj.set_field (Obj.repr e) 0 (Obj.repr eval_fun);
Obj.set_tag (Obj.repr e) tag_op_resolved;
......@@ -162,7 +162,7 @@ and eval_apply f arg = match f with
and eval_abstraction env locals slots iface body lsize sigma =
let env = Array.map (eval_var env locals) slots in
let f arg =
let f arg =
let v = eval_branches env (Array.create lsize Value.Absent) body arg in
if sigma <> Value.Mono then env.(1) <- arg;
(* pp_lambda_env Format.std_formatter env locals; *)
......@@ -179,13 +179,13 @@ and eval_branches env locals brs arg =
(* copy n elements from bindings into locals starting
* from position brs.brs_stack_pos *)
Array.blit bindings 0 locals brs.brs_stack_pos n;
eval env locals e
eval env locals e
| Auto_pat.Fail -> Value.Absent
and eval_ref env locals e t =
Value.mk_ref (Types.descr t) (eval env locals e)
and eval_validate env locals e s =
and eval_validate env locals e s =
try Schema_validator.run s (eval env locals e)
with Schema_common.XSI_validation_error msg ->
failwith' ("Schema validation failure: " ^ msg)
......@@ -201,14 +201,14 @@ and eval_map env locals brs v =
map (eval_map_aux env locals brs) v
and eval_map_aux env locals brs acc = function
| Value.Pair (x,y,sigma) ->
| Value.Pair (x,y,sigma) ->
let x = eval_branches env locals brs x in
let acc' = Value.Pair (x, Absent,sigma) in
set_cdr acc acc';
eval_map_aux env locals brs acc' y
| Value.String_latin1 (_,_,_,_) | Value.String_utf8 (_,_,_,_) as v ->
| Value.String_latin1 (_,_,_,_) | Value.String_utf8 (_,_,_,_) as v ->
eval_map_aux env locals brs acc (normalize v)
| Value.Concat (x,y) ->
| Value.Concat (x,y, _) ->
let acc = eval_map_aux env locals brs acc x in
eval_map_aux env locals brs acc y
| _ -> acc
......@@ -217,15 +217,15 @@ and eval_transform env locals brs v =
map (eval_transform_aux env locals brs) v
and eval_transform_aux env locals brs acc = function
| Value.Pair (x,y,sigma) ->
(match eval_branches env locals brs x with
| Value.Pair (x,y,sigma) ->
(match eval_branches env locals brs x with
| Value.Absent -> eval_transform_aux env locals brs acc y
| x -> eval_transform_aux env locals brs (append_cdr acc x) y)
| Value.String_latin1 (_,_,_,q) | Value.String_utf8 (_,_,_,q) as v ->
| Value.String_latin1 (_,_,_,q) | Value.String_utf8 (_,_,_,q) as v ->
if not brs.brs_accept_chars
then eval_transform_aux env locals brs acc q
else eval_transform_aux env locals brs acc (normalize v)
| Value.Concat (x,y) ->
| Value.Concat (x,y, _) ->
let acc = eval_transform_aux env locals brs acc x in
eval_transform_aux env locals brs acc y
| _ -> acc
......@@ -236,27 +236,27 @@ and eval_xtrans env locals brs v =
and eval_xtrans_aux env locals brs acc = function
| Value.String_utf8 (s,i,j,q) as v ->
if not brs.brs_accept_chars
then
then
let acc' = Value.String_utf8 (s,i,j, Absent) in
set_cdr acc acc';
eval_xtrans_aux env locals brs acc' q
else eval_xtrans_aux env locals brs acc (normalize v)
| Value.String_latin1 (s,i,j,q) as v ->
if not brs.brs_accept_chars
then
then
let acc' = Value.String_latin1 (s,i,j, Absent) in
set_cdr acc acc';
eval_xtrans_aux env locals brs acc' q
else eval_xtrans_aux env locals brs acc (normalize v)
| Value.Concat (x,y) ->
| Value.Concat (x,y, _) ->
let acc = eval_xtrans_aux env locals brs acc x in
eval_xtrans_aux env locals brs acc y
| Value.Pair (x,y,sigma) ->
let acc =
| Value.Pair (x,y,sigma) ->
let acc =
match eval_branches env locals brs x with
| Value.Absent ->
| Value.Absent ->
let x = match x with
| Value.Xml (tag, attr, child,sigma) ->
| Value.Xml (tag, attr, child,sigma) ->
let child = eval_xtrans env locals brs child in
Value.Xml (tag, attr, child,sigma)
| Value.XmlNs (tag, attr, child, ns,sigma) ->
......@@ -272,7 +272,7 @@ and eval_xtrans_aux env locals brs acc = function
| _ -> acc
and eval_dot l = function
| Value.Record (r,_)
| Value.Record (r,_)
| Value.Xml (_,Value.Record (r,_),_,_)
| Value.XmlNs (_,Value.Record (r,_),_,_,_) -> Imap.find_lower r (Upool.int l)
| v -> assert false
......@@ -299,12 +299,12 @@ let eval_toplevel = function
set globs !nglobs v;
incr nglobs
let eval_toplevel items =
let eval_toplevel items =
let n = !nglobs in
try List.iter eval_toplevel items
with exn -> nglobs := n; raise exn
let eval_var v =
let eval_var v =
eval_var [||] [||] v
(* Evaluation of a compiled unit *)
......@@ -322,8 +322,7 @@ let eval_unit globs nglobs = function
globs.(!nglobs) <- v;
incr nglobs
let eval_unit globs items =
let eval_unit globs items =
let nglobs = ref 0 in
List.iter (eval_unit globs nglobs) items;
assert (!nglobs = Array.length globs)
......@@ -9,7 +9,7 @@ let write_markup_string ~to_enc buf s =
else convert
~in_enc:`Enc_utf8
~out_enc:to_enc
~subst:(fun n ->
~subst:(fun n ->
failwith ("Cannot represent code point " ^ string_of_int n))
s
in
......@@ -18,10 +18,10 @@ let write_markup_string ~to_enc buf s =
let write_data_string ~to_enc buf s =
let write_part i len =
if (len > 0) then
if to_enc = `Enc_utf8
if to_enc = `Enc_utf8
then buf (String.sub s i len)
else
let s' =
let s' =
convert
~in_enc:`Enc_utf8
~out_enc:to_enc
......@@ -95,7 +95,7 @@ and schema_values ~wds ~wcs v =
schema_values ~wds ~wcs tl
| _ -> raise exn_print_xml
let to_buf ~utf8 buffer ns_table v subst =
let to_buf ~utf8 buffer ns_table v subst =
let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
let printer = Ns.Printer.printer ns_table in
......@@ -113,19 +113,19 @@ let to_buf ~utf8 buffer ns_table v subst =
wds (Ns.Uri.value ns);
wms "\"" in
let element_start q xmlns attrs =
wms ("<" ^ (Ns.Printer.tag printer (Atoms.V.value q)));
let element_start q xmlns attrs =
wms ("<" ^ (Ns.Printer.tag printer (Atoms.V.value q)));
List.iter write_xmlns xmlns;
List.iter write_att attrs;
List.iter write_att attrs;
wms ">"
and empty_element q xmlns attrs =
wms ("<" ^ (Ns.Printer.tag printer (Atoms.V.value q)));
and empty_element q xmlns attrs =
wms ("<" ^ (Ns.Printer.tag printer (Atoms.V.value q)));
List.iter write_xmlns xmlns;
List.iter write_att attrs;
List.iter write_att attrs;
wms "/>"
and element_end q =
and element_end q =
wms ("</" ^ (Ns.Printer.tag printer (Atoms.V.value q)) ^ ">")
and document_start () =
and document_start () =
(* wms ("<?xml version='1.0' encoding='" ^
Netconversion.string_of_encoding to_enc ^
"'?>\n") *)
......@@ -133,10 +133,10 @@ let to_buf ~utf8 buffer ns_table v subst =
in
let rec register_elt = function
| Xml (Atom q, Record (attrs, _), content, _)
| Xml (Atom q, Record (attrs, _), content, _)
| XmlNs (Atom q, Record (attrs, _), content, _, _) ->
Imap.iter
(fun n _ -> Ns.Printer.register_qname printer
(fun n _ -> Ns.Printer.register_qname printer
(Label.value (Label.from_int n)))
attrs;
Ns.Printer.register_qname printer (Atoms.V.value q);
......@@ -146,8 +146,8 @@ let to_buf ~utf8 buffer ns_table v subst =
| String_utf8 (_,_,_,q)
| String_latin1 (_,_,_,q) -> register_content q
| Pair (x, q, _) -> register_elt x; register_content q
| Concat (x,y) -> register_content x; register_content y
| _ -> ()
| Concat (x,y, _) -> register_content x; register_content y
| _ -> ()
in
register_elt v;
......@@ -155,11 +155,11 @@ let to_buf ~utf8 buffer ns_table v subst =
| Xml (Atom tag, Record (attrs, _), content, _)
| XmlNs (Atom tag, Record (attrs, _), content, _, _) ->
let attrs = Imap.map_elements
(fun n v ->
(fun n v ->
if is_str v then begin
let (s,q) = get_string_utf8 v in
match q with
| Atom a when a = Sequence.nil_atom ->
| Atom a when a = Sequence.nil_atom ->
(Label.from_int n), s
| _ -> raise exn_print_xml
end else begin
......@@ -206,7 +206,7 @@ let print_xml_subst ~utf8 ns_table s subst =
to_buf ~utf8 (Buffer.add_string buf) ns_table s subst;
let s = Buffer.contents buf in
if utf8 then string_utf8 (U.mk s) else string_latin1 s
let dump_xml ~utf8 ns_table s =
to_buf ~utf8 print_string ns_table s [];
Value.nil
......@@ -39,7 +39,7 @@ let push v =
incr cursor
let make_result_prod v1 v2 v (code,r,pop) =
let make_result_prod v1 v2 v (code,r,pop) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
......@@ -53,7 +53,7 @@ let make_result_prod v1 v2 v (code,r,pop) =
| Left -> v1
| Right -> v2
| Stack i -> buf.(c - i)
| Recompose (i,j) ->
| Recompose (i,j) ->
Pair (
(match i with (-1) -> v1 | (-2) -> nil | _ -> buf.(c - i)),
(match j with (-1) -> v2 | (-2) -> nil | _ -> buf.(c - j)),
......@@ -66,7 +66,7 @@ let make_result_prod v1 v2 v (code,r,pop) =
cursor := !cursor - pop + n; (* clean space for GC ? *)
code
let make_result_basic v (code,r,_) =
let make_result_basic v (code,r,_) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
......@@ -74,7 +74,7 @@ let make_result_basic v (code,r,_) =
for a = 0 to n - 1 do
let x = match Array.unsafe_get r a with
| Catch -> v
| Const c -> const c
| Const c -> const c
| _ -> assert false
in
buf.(!cursor) <- x;
......@@ -82,7 +82,7 @@ let make_result_basic v (code,r,_) =
done);
code
let make_result_char ch (code,r,_) =
let make_result_char ch (code,r,_) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
......@@ -101,7 +101,7 @@ let make_result_char ch (code,r,_) =
let tail_string_latin1 i j s q =
if i + 1 == j then q else String_latin1 (i + 1,j,s,q)
let make_result_string_latin1 i j s q (code,r,pop) =
let make_result_string_latin1 i j s q (code,r,pop) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
......@@ -115,15 +115,15 @@ let make_result_string_latin1 i j s q (code,r,pop) =
| Left -> Char (Chars.V.mk_char s.[i])
| Right -> tail_string_latin1 i j s q
| Stack n -> buf.(c - n)
| Recompose (n,m) ->
| Recompose (n,m) ->
Pair (
(match n with
| (-1) -> Char (Chars.V.mk_char s.[i])
| (-2) -> nil
(match n with
| (-1) -> Char (Chars.V.mk_char s.[i])
| (-2) -> nil
| _ -> buf.(c - n)),
(match m with
| (-1) -> tail_string_latin1 i j s q
| (-2) -> nil
(match m with
| (-1) -> tail_string_latin1 i j s q
| (-2) -> nil
| _ -> buf.(c - m)),
Value.Identity
)
......@@ -138,7 +138,7 @@ let tail_string_utf8 i j s q =
let i = Utf8.advance s i in
if Utf8.equal_index i j then q else String_utf8 (i,j,s,q)
let make_result_string_utf8 i j s q (code,r,pop) =
let make_result_string_utf8 i j s q (code,r,pop) =
let n = Array.length r in
if n > 0 then (
ensure_room n;
......@@ -150,17 +150,17 @@ let make_result_string_utf8 i j s q (code,r,pop) =
| Const c -> const c
| Nil -> nil
| Left -> Char (Chars.V.mk_int (Utf8.get s i))
| Right -> tail_string_utf8 i j s q
| Right -> tail_string_utf8 i j s q
| Stack n -> buf.(c - n)
| Recompose (n,m) ->
| Recompose (n,m) ->
Pair (
(match n with
| (-1) -> Char (Chars.V.mk_int (Utf8.get s i))
| (-2) -> nil
(match n with
| (-1) -> Char (Chars.V.mk_int (Utf8.get s i))
| (-2) -> nil
| _ -> buf.(c - n)),
(match m with
| (-1) -> tail_string_utf8 i j s q
| (-2) -> nil
(match m with
| (-1) -> tail_string_utf8 i j s q
| (-2) -> nil
| _ -> buf.(c - m)),
Value.Identity
)
......@@ -175,7 +175,7 @@ let make_result_string_utf8 i j s q (code,r,pop) =
let rec run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
| _ ->
| _ ->
Format.fprintf Format.std_formatter "ERR: %a@." Value.print v;
assert false
......@@ -191,7 +191,7 @@ let (@@) v sigma =
|Abstraction (iface,t,s) -> Abstraction (iface,t,comp sigma s)
|_ -> v
let rec eval_sigma env =
let rec eval_sigma env =
let open Value in function
|Mono -> []
|Identity -> []
......@@ -199,7 +199,7 @@ let rec eval_sigma env =
|Comp(s1,s2) -> (eval_sigma env s1) @ (eval_sigma env s2)
|Sel(x,iface,sigma) ->
List.fold_left (fun acc sigma_j ->
let exists_sub =
let exists_sub =
List.exists (fun (_,s_i) ->
inzero env env.(x) (Types.Tallying.(s_i $$ sigma_j))
) iface
......@@ -207,7 +207,7 @@ let rec eval_sigma env =
if exists_sub then sigma_j::acc else acc
) [] (eval_sigma env sigma)
and inzero env v t =
and inzero env v t =
let open Value in
match v with (* XXX I should chech p1(t) and p2(t) or \Omega *)
| Pair (v1,v2,sigma) -> (inzero env (v1 @@ sigma) t) && (inzero env (v2 @@ sigma) t)
......@@ -218,12 +218,12 @@ and inzero env v t =
| Abstraction (Some iface,_,Value.Identity) -> Types.Arrow.check_iface iface t
| Abstraction (Some iface,_,sigma) ->
let s = List.fold_left (fun acc t -> Types.cap acc (snd t)) Types.any iface in
List.for_all (fun si ->
List.for_all (fun si ->
Types.subtype (Types.Tallying.(s $$ si)) t
) (eval_sigma env sigma)
| _ -> true
let rec run_dispatcher env d v =
let rec run_dispatcher env d v =
(* Format.fprintf Format.std_formatter "Matching (%a) with:@." Value.print v; *)
match d.actions with
| AIgnore r -> make_result_basic v r
......@@ -236,25 +236,25 @@ and run_disp_kind env actions v =
| Xml (v1,v2,v3,sigma) | XmlNs (v1,v2,v3,_,sigma) ->
run_disp_prod env v (v1 @@ sigma) ((Pair (v2,v3,sigma)) @@ sigma) actions.xml
| Record (r,sigma) -> run_disp_record env 0 v r actions.record (* XXX !!!! apply sigma here *)
| String_latin1 (i,j,s,q) -> run_disp_string_latin1 env i j s q actions
| String_utf8 (i,j,s,q) -> run_disp_string_utf8 env i j s q actions
| Atom q -> make_result_basic v (Atoms.get_map q actions.atoms)
| Char c -> make_result_basic v (Chars.get_map c actions.chars)
| String_latin1 (i,j,s,q) -> run_disp_string_latin1 env i j s q actions
| String_utf8 (i,j,s,q) -> run_disp_string_utf8 env i j s q actions
| Atom q -> make_result_basic v (Atoms.get_map q actions.atoms)
| Char c -> make_result_basic v (Chars.get_map c actions.chars)
| Integer i -> run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
| Abstraction (None,_,_) ->
run_disp_basic v (fun t -> failwith "Run-time inspection of external abstraction")
actions.basic
| Abstraction (Some iface,_,Value.Identity) ->
run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
run_disp_basic v (fun t -> Types.Arrow.check_iface iface t)
actions.basic
| Abstraction (Some iface,_,sigma) ->
run_disp_basic v (fun t -> inzero env v t) actions.basic
| Abstract (abs,_) ->
| Abstract (abs,_) ->
run_disp_basic v (fun t -> Types.Abstract.has_abstract t abs (* Types.Abstracts.contains abs (Types.Abstract.get t) *))
actions.basic
| Absent ->
run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
| Concat (_,_) as v -> run_disp_kind env actions (Value.normalize v)
| Concat (_,_, _) as v -> run_disp_kind env actions (Value.normalize v)
and run_disp_prod env v v1 v2 = function
| Impossible -> assert false
......@@ -300,9 +300,9 @@ and run_disp_record_loop env v n rem d =
match d.actions with
| AIgnore r -> make_result_basic v r
| AKind k -> run_disp_record env n v rem k.record
and run_disp_string_latin1 env i j s q actions =
if i == j then run_disp_kind env actions q
and run_disp_string_latin1 env i j s q actions =
if i == j then run_disp_kind env actions q
else match actions.prod with
| Impossible -> assert false
| TailCall d1 -> run_disp_string_latin1_char d1 (Chars.V.mk_char s.[i])
......@@ -313,10 +313,10 @@ and run_disp_string_latin1 env i j s q actions =
and run_disp_string_latin1_char d ch =
match d.actions with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_latin1_2 env i j s q = function
| Impossible -> assert false
| Ignore r ->
| Ignore r ->
make_result_string_latin1 i j s q r
| TailCall d2 -> run_disp_string_latin1_loop env i j s q d2
| Dispatch (d2,b2) ->
......@@ -329,7 +329,7 @@ and run_disp_string_latin1_loop env i j s q d =
| AIgnore r -> make_result_basic (Value.String_latin1 (i,j,s,q)) r
| AKind k -> run_disp_string_latin1 env i j s q k
and run_disp_string_utf8 env i j s q actions =
and run_disp_string_utf8 env i j s q actions =
if Utf8.equal_index i j then run_disp_kind env actions q
else
match actions.prod with
......@@ -342,10 +342,10 @@ and run_disp_string_utf8 env i j s q actions =
and run_disp_string_utf8_char d ch =
match d.actions with
| AIgnore r -> make_result_char ch r
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
| AKind k -> make_result_char ch (Chars.get_map ch k.chars)
and run_disp_string_utf8_2 env i j s q = function
| Impossible -> assert false
| Ignore r ->
| Ignore r ->
make_result_string_utf8 i j s q r
| TailCall d2 -> run_disp_string_utf8_loop env i j s q d2
| Dispatch (d2,b2) ->
......@@ -361,4 +361,4 @@ and run_disp_string_utf8_loop env i j s q d =
let run_dispatcher env d v =
let code = run_dispatcher env d v in
cursor := 0;
(code,!buffer)
(code,!buffer)
......@@ -21,7 +21,7 @@ and t =
| Abstract of Types.Abstracts.V.t
| String_latin1 of int * int * string * t
| String_utf8 of Utf8.uindex * Utf8.uindex * Utf8.t * t
| Concat of t * t
| Concat of t * t * sigma
| Absent
let rec domain = function
......@@ -63,7 +63,7 @@ let rec comp s1 s2 = match s1, s2 with
(* Default: comp s1 s2 -> Comp(s1, s2). *)
| _, _ -> Comp(s1, s2)
(*
(*
The only representation of the empty sequence is nil.
In particular, in String_latin1 and String_utf8, the string cannot be empty.
*)
......@@ -73,14 +73,14 @@ let dump_forward = ref (fun _ _ -> assert false)
exception CDuceExn of t
let nil = Atom Sequence.nil_atom
let string_latin1 s =
let string_latin1 s =
if String.length s = 0 then nil
else String_latin1 (0,String.length s, s, nil)
let string_utf8 s =
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
if Utf8.equal_index i j then q
else String_utf8 (i,j,s,q)
let vtrue = Atom (Atoms.V.mk_ascii "true")
let vfalse = Atom (Atoms.V.mk_ascii "false")
......@@ -117,10 +117,10 @@ let tuple_of_array a =
let n = Array.length a in
aux a.(n) (pred n)
let concat v1 v2 =
let concat v1 v2 =
match (v1,v2) with
| (Atom _, v) | (v, Atom _) -> v
| (v1,v2) -> Concat (v1,v2)
| (v1,v2) -> Concat (v1,v2, Mono)
let append v1 v2 =
concat v1 (Pair (v2,nil,Mono))
......@@ -134,7 +134,7 @@ let rec const = function
| Types.Pair (x,y) -> Pair (const x, const y,Mono)
| Types.Xml (x, Types.Pair (y, z)) -> Xml (const x, const y, const z,Mono)
| Types.Xml (_,_) -> assert false
| Types.Record x ->