+ else empty
+ let mk_quick_tag_loop f _ _ _ _ = f
+ let mk_quick_star_loop f _ _ _ = f
+ end
+ module GResult(Doc : sig val doc : Tree.t end) = struct
+ type bits
+ type elt = [` Tree] Tree.node
+ external create_empty : int -> bits = "caml_result_set_create"
+ external set : bits -> int -> unit = "caml_result_set_set"
+ external next : bits -> int -> int = "caml_result_set_next"
+ external clear : bits -> elt -> elt -> unit = "caml_result_set_clear"
+
+ type t =
+ { segments : elt list;
+ bits : bits;
+ }
+
+ let ebits =
+ let size = (Tree.subtree_size Doc.doc Tree.root) in
+ create_empty (size*2+1)
+
+ let empty = { segments = [];
+ bits = ebits }
+
+ let cons e t =
+ let rec loop l = match l with
+ | [] -> { bits = (set t.bits (Obj.magic e);t.bits);
+ segments = [ e ] }
+ | p::r ->
+ if Tree.is_binary_ancestor Doc.doc e p then
+ loop r
+ else
+ { bits = (set t.bits (Obj.magic e);t.bits);
+ segments = e::l }
+ in
+ loop t.segments
+
+ let concat t1 t2 =
+ if t2.segments == [] then t1
+ else
+ if t1.segments == [] then t2
+ else
+ let h2 = List.hd t2.segments in
+ let rec loop l = match l with
+ | [] -> t2.segments
+ | p::r ->
+ if Tree.is_binary_ancestor Doc.doc p h2 then
+ l
+ else
+ p::(loop r)
+ in
+ { bits = t1.bits;
+ segments = loop t1.segments
+ }
+
+ let iter f t =
+ let rec loop i =
+ if i == -1 then ()
+ else (f ((Obj.magic i):elt);loop (next t.bits i))
+ in loop (next t.bits 0)
+
+ let fold _ _ _ = failwith "noop"
+ let map _ _ = failwith "noop"
+ let length t = let cpt = ref 0 in
+ iter (fun _ -> incr cpt) t; !cpt
+
+ let merge (rb,rb1,rb2,mark) elt t1 t2 =
+ if rb then
+(* let _ = Printf.eprintf "Lenght before merging is %i %i\n"
+ (List.length t1.segments) (List.length t2.segments)
+ in *)
+ match t1.segments,t2.segments with
+ [],[] -> if mark then cons elt empty else empty
+ | [p],[] when rb1 -> if mark then cons elt t1 else t1
+ | [], [p] when rb2 -> if mark then cons elt t2 else t2
+ | [x],[y] when rb1 && rb2 -> if mark then cons elt empty else
+ concat t1 t2
+ | _,_ ->
+ let t1 = if rb1 then t1 else
+ (List.iter (fun idx -> clear t1.bits idx (Tree.closing Doc.doc idx)) t1.segments;empty)
+ and t2 = if rb2 then t2 else
+ (List.iter (fun idx -> clear t2.bits idx (Tree.closing Doc.doc idx)) t2.segments;empty)
+ in
+ (if mark then cons elt (concat t1 t2)
+ else concat t1 t2)
+ else
+ let _ =
+ List.iter (fun idx -> clear t1.bits idx (Tree.closing Doc.doc idx)) t1.segments;
+ List.iter (fun idx -> clear t2.bits idx (Tree.closing Doc.doc idx)) t2.segments
+ in
+ empty
+ let mk_quick_tag_loop f _ _ _ _ = f
+ let mk_quick_star_loop f _ _ _ = f