Commit a8c712ec authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-06-17 14:55:43 by afrisch] New representation for integer maps (used...

[r2005-06-17 14:55:43 by afrisch] New representation for integer maps (used for dispatcher on atoms and
for record values

Original author: afrisch
Date: 2005-06-17 14:55:44+00:00
parent 1d4ae7d9
...@@ -73,7 +73,10 @@ and compile_aux env tail = function ...@@ -73,7 +73,10 @@ and compile_aux env tail = function
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) -> | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) ->
XmlNs (compile env false e1, compile env false e2, compile env tail e3,t) XmlNs (compile env false e1, compile env false e2, compile env tail e3,t)
| Typed.Xml _ -> assert false | Typed.Xml _ -> assert false
| Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r) | Typed.RecordLitt r ->
let r = List.map (fun (l,e) -> (l, compile env false e)) (LabelMap.get r)
in
Record (Imap.create (Array.of_list r))
| Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q) | Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
| Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs) | Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
| Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs) | Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs)
......
...@@ -51,7 +51,7 @@ type expr = ...@@ -51,7 +51,7 @@ type expr =
| Pair of expr * expr | Pair of expr * expr
| Xml of expr * expr * expr | Xml of expr * expr * expr
| XmlNs of expr * expr * expr * Ns.table | XmlNs of expr * expr * expr * Ns.table
| Record of expr label_map | Record of expr Imap.t
| String of U.uindex * U.uindex * U.t * expr | String of U.uindex * U.uindex * U.t * expr
| Match of expr * branches | Match of expr * branches
...@@ -174,7 +174,8 @@ module Put = struct ...@@ -174,7 +174,8 @@ module Put = struct
Ns.serialize_table s ns Ns.serialize_table s ns
| Record r -> | Record r ->
bits nbits s 6; bits nbits s 6;
LabelMap.serialize expr s r Serialize.Put.list (Serialize.Put.pair LabelPool.serialize expr) s
(Imap.elements r)
| String (i,j,st,q) -> | String (i,j,st,q) ->
bits nbits s 7; bits nbits s 7;
U.serialize_sub s st i j; U.serialize_sub s st i j;
...@@ -305,7 +306,10 @@ module Get = struct ...@@ -305,7 +306,10 @@ module Get = struct
XmlNs (e1,e2,e3,ns) XmlNs (e1,e2,e3,ns)
else else
Xml (e1,e2,e3) Xml (e1,e2,e3)
| 6 -> Record (LabelMap.deserialize expr s) | 6 ->
let r = Serialize.Get.list
(Serialize.Get.pair LabelPool.deserialize expr) s in
Record (Imap.create (Array.of_list r))
| 7 -> | 7 ->
let st = U.deserialize s in let st = U.deserialize s in
let e = expr s in let e = expr s in
......
...@@ -23,7 +23,7 @@ type expr = ...@@ -23,7 +23,7 @@ type expr =
| Pair of expr * expr | Pair of expr * expr
| Xml of expr * expr * expr | Xml of expr * expr * expr
| XmlNs of expr * expr * expr * Ns.table | XmlNs of expr * expr * expr * Ns.table
| Record of expr label_map | Record of expr Imap.t
| String of U.uindex * U.uindex * U.t * expr | String of U.uindex * U.uindex * U.t * expr
| Match of expr * branches | Match of expr * branches
......
...@@ -87,11 +87,11 @@ compile/lambda.cmo: types/types.cmi misc/serialize.cmi types/patterns.cmi \ ...@@ -87,11 +87,11 @@ compile/lambda.cmo: types/types.cmi misc/serialize.cmi types/patterns.cmi \
compile/lambda.cmx: types/types.cmx misc/serialize.cmx types/patterns.cmx \ compile/lambda.cmx: types/types.cmx misc/serialize.cmx types/patterns.cmx \
misc/ns.cmx types/ident.cmx compile/lambda.cmi misc/ns.cmx types/ident.cmx compile/lambda.cmi
runtime/value.cmo: types/types.cmi types/sequence.cmi misc/ns.cmi \ runtime/value.cmo: types/types.cmi types/sequence.cmi misc/ns.cmi \
compile/lambda.cmi types/intervals.cmi types/ident.cmo misc/encodings.cmi \ compile/lambda.cmi types/intervals.cmi misc/imap.cmi types/ident.cmo \
types/chars.cmi types/atoms.cmi runtime/value.cmi misc/encodings.cmi types/chars.cmi types/atoms.cmi runtime/value.cmi
runtime/value.cmx: types/types.cmx types/sequence.cmx misc/ns.cmx \ runtime/value.cmx: types/types.cmx types/sequence.cmx misc/ns.cmx \
compile/lambda.cmx types/intervals.cmx types/ident.cmx misc/encodings.cmx \ compile/lambda.cmx types/intervals.cmx misc/imap.cmx types/ident.cmx \
types/chars.cmx types/atoms.cmx runtime/value.cmi misc/encodings.cmx types/chars.cmx types/atoms.cmx runtime/value.cmi
parser/location.cmo: misc/html.cmi parser/location.cmi parser/location.cmo: misc/html.cmi parser/location.cmi
parser/location.cmx: misc/html.cmx parser/location.cmi parser/location.cmx: misc/html.cmx parser/location.cmi
parser/url.cmo: parser/location.cmi parser/url.cmi parser/url.cmo: parser/location.cmi parser/url.cmi
...@@ -202,12 +202,10 @@ runtime/run_dispatch.cmx: runtime/value.cmx types/types.cmx \ ...@@ -202,12 +202,10 @@ runtime/run_dispatch.cmx: runtime/value.cmx types/types.cmx \
types/atoms.cmx runtime/run_dispatch.cmi types/atoms.cmx runtime/run_dispatch.cmi
runtime/explain.cmo: runtime/value.cmi types/types.cmi \ runtime/explain.cmo: runtime/value.cmi types/types.cmi \
runtime/run_dispatch.cmi types/patterns.cmi types/ident.cmo \ runtime/run_dispatch.cmi types/patterns.cmi types/ident.cmo \
misc/encodings.cmi types/chars.cmi compile/auto_opt.cmi types/atoms.cmi \ misc/encodings.cmi types/chars.cmi types/atoms.cmi runtime/explain.cmi
runtime/explain.cmi
runtime/explain.cmx: runtime/value.cmx types/types.cmx \ runtime/explain.cmx: runtime/value.cmx types/types.cmx \
runtime/run_dispatch.cmx types/patterns.cmx types/ident.cmx \ runtime/run_dispatch.cmx types/patterns.cmx types/ident.cmx \
misc/encodings.cmx types/chars.cmx compile/auto_opt.cmx types/atoms.cmx \ misc/encodings.cmx types/chars.cmx types/atoms.cmx runtime/explain.cmi
runtime/explain.cmi
runtime/print_xml.cmo: runtime/value.cmi types/sequence.cmi \ runtime/print_xml.cmo: runtime/value.cmi types/sequence.cmi \
schema/schema_builtin.cmi misc/ns.cmi types/intervals.cmi types/ident.cmo \ schema/schema_builtin.cmi misc/ns.cmi types/intervals.cmi types/ident.cmo \
misc/encodings.cmi types/atoms.cmi runtime/print_xml.cmi misc/encodings.cmi types/atoms.cmi runtime/print_xml.cmi
...@@ -217,11 +215,11 @@ runtime/print_xml.cmx: runtime/value.cmx types/sequence.cmx \ ...@@ -217,11 +215,11 @@ runtime/print_xml.cmx: runtime/value.cmx types/sequence.cmx \
runtime/eval.cmo: runtime/value.cmi types/types.cmi typing/typer.cmi \ runtime/eval.cmo: runtime/value.cmi types/types.cmi typing/typer.cmi \
schema/schema_common.cmi runtime/run_dispatch.cmi types/patterns.cmi \ schema/schema_common.cmi runtime/run_dispatch.cmi types/patterns.cmi \
misc/ns.cmi compile/lambda.cmi types/ident.cmo runtime/explain.cmi \ misc/ns.cmi compile/lambda.cmi types/ident.cmo runtime/explain.cmi \
compile/auto_opt.cmi runtime/eval.cmi runtime/eval.cmi
runtime/eval.cmx: runtime/value.cmx types/types.cmx typing/typer.cmx \ runtime/eval.cmx: runtime/value.cmx types/types.cmx typing/typer.cmx \
schema/schema_common.cmx runtime/run_dispatch.cmx types/patterns.cmx \ schema/schema_common.cmx runtime/run_dispatch.cmx types/patterns.cmx \
misc/ns.cmx compile/lambda.cmx types/ident.cmx runtime/explain.cmx \ misc/ns.cmx compile/lambda.cmx types/ident.cmx runtime/explain.cmx \
compile/auto_opt.cmx runtime/eval.cmi runtime/eval.cmi
compile/compile.cmo: types/types.cmi typing/typer.cmi typing/typed.cmo \ compile/compile.cmo: types/types.cmi typing/typer.cmi typing/typed.cmo \
misc/serialize.cmi types/patterns.cmi parser/location.cmi \ misc/serialize.cmi types/patterns.cmi parser/location.cmi \
compile/lambda.cmi types/ident.cmo runtime/eval.cmi parser/ast.cmo \ compile/lambda.cmi types/ident.cmo runtime/eval.cmi parser/ast.cmo \
...@@ -374,8 +372,8 @@ types/builtin_defs.cmi: types/types.cmi types/ident.cmo types/atoms.cmi ...@@ -374,8 +372,8 @@ types/builtin_defs.cmi: types/types.cmi types/ident.cmo types/atoms.cmi
compile/lambda.cmi: types/types.cmi misc/serialize.cmi types/patterns.cmi \ compile/lambda.cmi: types/types.cmi misc/serialize.cmi types/patterns.cmi \
misc/ns.cmi types/ident.cmo misc/ns.cmi types/ident.cmo
runtime/value.cmi: types/types.cmi misc/ns.cmi compile/lambda.cmi \ runtime/value.cmi: types/types.cmi misc/ns.cmi compile/lambda.cmi \
types/intervals.cmi types/ident.cmo misc/encodings.cmi types/chars.cmi \ types/intervals.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
types/atoms.cmi types/chars.cmi types/atoms.cmi
parser/location.cmi: misc/html.cmi parser/location.cmi: misc/html.cmi
parser/parser.cmi: parser/ast.cmo parser/parser.cmi: parser/ast.cmo
types/externals.cmi: types/types.cmi types/externals.cmi: types/types.cmi
......
(* Patricia trees; code adapted from http://www.lri.fr/~filliatr/ftp/ocaml/misc/ptmap.ml *) type 'a t = int array
type 'a t = let get = Array.unsafe_get
| Empty let set = Array.unsafe_set
| Leaf of int * 'a
| Branch of int * int * 'a t * 'a t let empty = [| |]
type 'a s = let elements (t : 'a t) : (int * 'a) list =
| DError if t == empty then [] else
| DReturn of 'a let rec aux accu i =
| DLeaf of int * 'a * 'a if (i > 0)
| DBranch of int * int * 'a s * 'a s then aux ((get t i, Obj.magic (get t (succ i)))::accu) (i - 2)
else accu
let empty = Empty in
aux [] (get t 0 - 2)
let return x = DReturn x
let map_elements f t =
let zero_bit k m = (k land m) == 0 if t == empty then [] else
let lowest_bit x = x land (-x) let rec aux accu i =
let branching_bit p0 p1 = lowest_bit (p0 lxor p1) if (i > 0)
let mask p m = p land (m-1) then aux (f (get t i) (Obj.magic (get t (succ i)))::accu) (i - 2)
let match_prefix k p m = (mask k m) == p else accu
in
let rec prepare_def y = function aux [] (get t 0 - 2)
| Empty -> DReturn y
| Leaf (k,x) -> DLeaf (k,x,y) let sort a =
| Branch (p,m,t0,t1) -> Array.sort (fun (i,_) (j,_) -> assert (i != j); if i < j then (-1) else 1) a
DBranch (p,m,prepare_def y t0, prepare_def y t1)
let real_create a =
let rec prepare_nodef = function let n = Array.length a in
| Empty -> DError let m = (n lsl 1) + 1 in
| Leaf (k,x) -> DReturn x let t = Array.create m m in
| Branch (p,m,t0,t1) -> for i = 1 to n do
match (prepare_nodef t0, prepare_nodef t1) with let j = i lsl 1 in
| (DReturn x0, DReturn x1) when x0 == x1 -> DReturn x0 let (idx,v) = get a (pred i) in
| (t0,t1) -> DBranch (p,m,t0,t1) set t (pred j) idx;
set t j (Obj.magic v);
let prepare def y = done;
match def with t
| None -> prepare_nodef y
| Some def -> prepare_def def y let create a =
if Array.length a = 0 then empty else (sort a; real_create a)
let rec find k = function
| DError -> assert false let create_default def a =
| DReturn y -> y sort a;
| DLeaf (j,x,y) -> if k == j then x else y let l = Array.to_list a in
| DBranch (_, m, l, r) -> find k (if zero_bit k m then l else r) let rec aux i = function
| [] ->
let join p0 t0 p1 t1 = if (i == max_int) then []
let m = branching_bit p0 p1 in else [(succ i, def)]
if zero_bit p0 m | ((i1,_) as c)::rest ->
then Branch (mask p0 m, m, t0, t1) if (succ i == i1) then c :: (aux i1 rest)
else Branch (mask p0 m, m, t1, t0) else (succ i, def) :: c :: (aux i1 rest)
in
let rec add k x = function let l =
| Empty -> Leaf (k,x) match l with
| Leaf (j,_) as t -> | ((i1,_) as c)::rest ->
if j == k then Leaf (k,x) else join k (Leaf (k,x)) j t if (i1 == min_int) then c :: (aux i1 rest)
| Branch (p,m,t0,t1) as t -> else (min_int,def) :: c :: (aux i1 rest)
if match_prefix k p m | [] -> [(min_int,def)] in
then let a = Array.of_list l in
if zero_bit k m real_create a
then Branch (p, m, add k x t0, t1)
else Branch (p, m, t0, add k x t1)
let rec find_aux t (i : int) low high =
if (low >= high) then low
else
let m = ((low + high) lsr 1) lor 1 in
if i < get t m then find_aux t i low (m-2)
else find_aux t i m high
let find (t : 'a t) i : 'a =
if t == empty then raise Not_found;
let j = find_aux t i 1 (get t 0) in
if (get t j == i) then (Obj.magic get t (succ j))
else raise Not_found
let find_default t def i =
if t == empty then def
else
let j = find_aux t i 1 (get t 0) in
if (get t j == i) then (Obj.magic get t (succ j))
else def
let find_lower (t : 'a t) i : 'a =
assert (t != empty);
Obj.magic get t (succ (find_aux t i 1 (get t 0)))
let merge (t1 : 'a t) (t2 : 'a t) =
if t1 == empty then t2 else if t2 == empty then t1
else
let n1 = get t1 0 and n2 = get t2 0 in
let m = pred (n1 + n2) in
let t = Array.create m m in
let rec aux i i1 (l1:int) i2 l2 =
if l1 == l2 then
(set t i l1;
set t (succ i) (get t2 (pred i2));
let i = i + 2 in
if (i1 = n1) then (
let l = n2 - i2 in
let i2 = i2 - 2 in
Array.blit t2 i2 t i l;
i + l
) else if (i2 = n2) then (
let l = n1 - i1 in
let i1 = i1 - 2 in
Array.blit t1 i1 t i l;
i + l
) else
let l1 = get t1 i1 and l2 = get t2 i2 in
let i1 = i1 + 2 and i2 = i2 + 2 in
aux i i1 l1 i2 l2)
else if l1 < l2 then
(set t i l1;
set t (succ i) (get t1 (pred i1));
let i = i + 2 in
if (i1 = n1) then (
let i2 = i2 - 2 in
let l = n2 - i2 in
Array.blit t2 i2 t i l;
i + l
) else
let l1 = get t1 i1 in
let i1 = i1 + 2 in
aux i i1 l1 i2 l2)
else
(set t i l2;
set t (succ i) (get t2 (pred i2));
let i = i + 2 in
if (i2 = n2) then (
let l = n1 - i1 in
let i1 = i1 - 2 in
Array.blit t1 i1 t i l;
i + l
) else
let l2 = get t2 i2 in
let i2 = i2 + 2 in
aux i i1 l1 i2 l2)
in
set t 0 (aux 1 3 (get t1 1) 3 (get t2 1));
t
let cardinal t =
if t == empty then 0
else (pred (get t 0)) lsr 1
let map f t =
if t == empty then empty
else
let n = get t 0 in
let t' = Array.create n 0 in
Array.blit t 0 t' 0 n;
let rec aux i =
if (i = 0) then t'
else (set t' i (Obj.magic (f (Obj.magic (get t i)))); aux (i - 2))
in
aux (pred n)
let compare f t1 t2 =
if (t1 == t2) then 0
else if t1 == empty then (-1)
else if t2 == empty then 1
else
let n1 = get t1 0 and n2 = get t2 0 in
if (n1 < n2) then (-1) else if (n1 > n2) then 1
else
let rec aux i =
if (i < 0) then 0
else
let l1 = get t1 i and l2 = get t2 i in
if (l1 < l2) then (-1) else if (l1 > l2) then 1
else let x1 = Obj.magic (get t1 (succ i))
and x2 = Obj.magic (get t2 (succ i))
in let c = f x1 x2 in
if c != 0 then c else aux (i - 2)
in
aux (n1 - 2)
let hash f t =
if t == empty then 1
else
let rec aux accu i =
if (i < 0) then accu
else aux (accu * 65537
+ 257 * (f (Obj.magic (get t (succ i))))
+ (get t i)) (i - 2) in
aux 1 (get t 0 - 2)
let remove t i =
if t == empty then t
else
let j = find_aux t i 1 (get t 0) in
if (get t j != i) then t
else
let n = get t 0 - 2 in
if (n = 1) then empty
else else
join k (Leaf (k,x)) p t let t' = Array.create n n in
Array.blit t 1 t' 1 (j - 1);
let rec dump f ppf = function Array.blit t (j + 2) t' j (n - j);
| DError -> Format.fprintf ppf "Error" t'
| DReturn x -> Format.fprintf ppf "Return %a" f x
| DLeaf(j,x,y) -> Format.fprintf ppf "Leaf(%i,%a,%a)" j f x f y let iter f t =
| DBranch (p,m,t0,t1) -> if t == empty then ()
Format.fprintf ppf "B(%i,%i,%a,%a)" p m (dump f) t0 (dump f) t1 else
let rec aux i =
if (i < 0) then ()
else f (get t i) (Obj.magic (get t (succ i))) in
aux (get t 0 - 2)
(** Compact maps from integers to values. **)
type 'a t type 'a t
type 'a s
val add: int -> 'a -> 'a t -> 'a t
val empty: 'a t val empty: 'a t
val return: 'a -> 'a s val create: (int * 'a) array -> 'a t
val prepare: 'a option -> 'a t -> 'a s (** The integer keys must be pairwise disjoint. *)
val find: int -> 'a s -> 'a
val dump : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a s -> unit
val create_default: 'a -> (int * 'a) array -> 'a t
(** Same as [create] but add necessary bindings so that
[find_lower] returns a default value when the key is not
in the set of the bindings which are provided. *)
val merge: 'a t -> 'a t -> 'a t
(** Merge two maps, with a priority to the second one in case of conflict.
Complexity linear in the size of the result. *)
val find: 'a t -> int -> 'a
(** Find the value associated to a key, or raise [Not_found]. *)
val find_default: 'a t -> 'a -> int -> 'a
(** Find the value associated to a key, or return a default value. *)
val find_lower: 'a t -> int -> 'a
(** Find the value associated to the largest key smaller than
or equal to the integer. It is assumed that such a key exists. *)
val find: 'a t -> int -> 'a
(** Find the value associated to a key, or raise [Not_found]. *)
val cardinal: 'a t -> int
(** Number of keys in the map. *)
val elements: 'a t -> (int * 'a) list
val map: ('a -> 'b) -> 'a t -> 'b t
val map_elements: (int -> 'a -> 'b) -> 'a t -> 'b list
val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
val hash: ('a -> int) -> 'a t -> int
val remove: 'a t -> int -> 'a t
val iter: (int -> 'a -> unit) -> 'a t -> unit
...@@ -132,7 +132,8 @@ let rec eval env = function ...@@ -132,7 +132,8 @@ let rec eval env = function
let v2 = eval env e2 in let v2 = eval env e2 in
let v3 = eval env e3 in let v3 = eval env e3 in
Value.XmlNs (v1,v2,v3,ns) Value.XmlNs (v1,v2,v3,ns)
| Record r -> Value.Record (LabelMap.map (eval env) r) | Record r ->
Value.Record (Imap.map (eval env) r)
| String (i,j,s,q) -> Value.substring_utf8 i j s (eval env q) | String (i,j,s,q) -> Value.substring_utf8 i j s (eval env q)
| Match (e,brs) -> eval_branches env brs (eval env e) | Match (e,brs) -> eval_branches env brs (eval env e)
...@@ -306,13 +307,13 @@ and eval_xtrans_aux env brs acc = function ...@@ -306,13 +307,13 @@ and eval_xtrans_aux env brs acc = function
and eval_dot l = function and eval_dot l = function
| Value.Record r | Value.Record r
| Value.Xml (_,Value.Record r,_) | Value.Xml (_,Value.Record r,_)
| Value.XmlNs (_,Value.Record r,_,_) -> LabelMap.assoc l r | Value.XmlNs (_,Value.Record r,_,_) -> Imap.find_lower r l
| v -> | v ->
Value.print Format.std_formatter v; Value.print Format.std_formatter v;
failwith ("Cannot find field " ^ (Label.to_string (LabelPool.value l))) failwith ("Cannot find field " ^ (Label.to_string (LabelPool.value l)))
and eval_remove_field l = function and eval_remove_field l = function
| Value.Record r -> Value.Record (LabelMap.remove l r) | Value.Record r -> Value.Record (Imap.remove r l)
| _ -> assert false | _ -> assert false
......
...@@ -67,7 +67,7 @@ and run_disp pt fail d v = ...@@ -67,7 +67,7 @@ and run_disp pt fail d v =
and run_disp_kind pt d fail actions = function and run_disp_kind pt d fail actions = function
| Pair (v1,v2) -> run_disp_prod pt d fail v1 v2 actions.prod | Pair (v1,v2) -> run_disp_prod pt d fail v1 v2 actions.prod
| Xml (v1,v2,v3) -> run_disp_prod pt d fail v1 (Pair(v2,v3)) actions.xml | Xml (v1,v2,v3) -> run_disp_prod pt d fail v1 (Pair(v2,v3)) actions.xml
| Record r -> run_disp_record pt d fail false (LabelMap.get r) actions.record | Record r -> run_disp_record pt d fail false (Imap.elements r) actions.record
| Atom a -> make_result pt fail (Atoms.get_map a actions.atoms) | Atom a -> make_result pt fail (Atoms.get_map a actions.atoms)
| Char c -> make_result pt fail (Chars.get_map c actions.chars) | Char c -> make_result pt fail (Chars.get_map c actions.chars)
| Integer i -> | Integer i ->
......
...@@ -42,7 +42,7 @@ let string s q = ...@@ -42,7 +42,7 @@ let string s q =
let attrib att = let attrib att =
(* TODO: better error message *) (* TODO: better error message *)
let att = List.map (fun (n,v) -> LabelPool.mk n, string_utf8 v) att in let att = List.map (fun (n,v) -> LabelPool.mk n, string_utf8 v) att in
LabelMap.from_list (fun _ _ -> failwith "Invalid XML document: uniqueness of attributes") att Imap.create (Array.of_list att)
let elem ns (tag_ns,tag) att child = let elem ns (tag_ns,tag) att child =
if !keep_ns then if !keep_ns then
......
...@@ -131,9 +131,9 @@ let string_of_xml ~utf8 ns_table v = ...@@ -131,9 +131,9 @@ let string_of_xml ~utf8 ns_table v =
let rec register_elt = function let rec register_elt = function
| Xml (Atom tag, Record attrs, content) | Xml (Atom tag, Record attrs, content)
| XmlNs (Atom tag, Record attrs, content, _) -> | XmlNs (Atom tag, Record attrs, content, _) ->
List.iter Imap.iter
(fun (n,_) -> Ns.Printer.register_attr printer (LabelPool.value n)) (fun n _ -> Ns.Printer.register_attr printer (LabelPool.value n))
(LabelMap.get attrs); attrs;
Ns.Printer.register_tag printer (Atoms.V.value tag); Ns.Printer.register_tag printer (Atoms.V.value tag);
register_content content register_content content
| _ -> () | _ -> ()
...@@ -150,7 +150,7 @@ let string_of_xml ~utf8 ns_table v = ...@@ -150,7 +150,7 @@ let string_of_xml ~utf8 ns_table v =
| Xml (Atom tag, Record attrs, content) | Xml (Atom tag, Record attrs, content)
| XmlNs (Atom tag, Record attrs, content, _) -> | XmlNs (Atom tag, Record attrs, content, _) ->
let tag = Atoms.V.value tag in let tag = Atoms.V.value tag in
let attrs = LabelMap.mapi_to_list let attrs = Imap.map_elements
(fun n v -> (fun n v ->
if is_str v then begin if is_str v then begin
let (s,q) = get_string_utf8 v in let (s,q) = get_string_utf8 v in
......
...@@ -190,7 +190,7 @@ and run_disp_kind actions v = ...@@ -190,7 +190,7 @@ and run_disp_kind actions v =
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3)