tree.ml

   1 (******************************************************************************)
   2 (*  SXSI : XPath evaluator                                                    *)
   3 (*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
   4 (*  Copyright NICTA 2008                                                      *)
   5 (*  Distributed under the terms of the LGPL (see LICENCE)                     *)
   6 (******************************************************************************)
   7 INCLUDE "utils.ml"
   8
   9
  10 external init_lib : unit -> unit = "caml_init_lib"
  11
  12 exception CPlusPlusError of string
  13
  14 let () = Callback.register_exception "CPlusPlusError" (CPlusPlusError "")
  15
  16 let () =  init_lib ()
  17
  18
  19 type tree
  20 type 'a node = private int
  21 type node_kind = [`Text | `Tree ]
  22
  23 type t = {
  24   doc : tree;
  25   ttable : (Tag.t,(Ptset.Int.t*Ptset.Int.t*Ptset.Int.t*Ptset.Int.t)) Hashtbl.t;
  26 }
  27
  28 external inode : 'a node -> int = "%identity"
  29 external nodei : int -> 'a node = "%identity"
  30 let compare_node x y = (inode x) - (inode y)
  31 let equal_node : 'a node -> 'a node -> bool = (==)
  32
  33
  34 external parse_xml_uri : string -> int -> bool -> bool -> tree = "caml_call_shredder_uri"
  35 external parse_xml_string :  string -> int -> bool -> bool -> tree = "caml_call_shredder_string"
  36 external tree_print_xml_fast3 : tree -> [`Tree ] node -> Unix.file_descr ->unit = "caml_xml_tree_print"
  37 external tree_save : tree -> Unix.file_descr -> unit = "caml_xml_tree_save"
  38 external tree_load : Unix.file_descr -> bool -> int -> tree = "caml_xml_tree_load"
  39
  40 external nullt : unit -> 'a node = "caml_xml_tree_nullt"
  41
  42 let nil : [`Tree ] node = nodei ~-1
  43 let nulldoc : [`Text ] node = nodei ~-1
  44 let root : [`Tree ] node = nodei 0
  45
  46 external text_get_tc_text : tree -> [`Text] node -> string = "caml_text_collection_get_text"
  47
  48 external text_is_empty : tree -> [`Text ] node -> bool = "caml_text_collection_empty_text"
  49
  50 let text_is_empty t n = (equal_node nulldoc n) || text_is_empty t n
  51
  52 external text_is_contains : tree -> string -> bool = "caml_text_collection_is_contains"
  53 external text_count_contains : tree -> string -> int = "caml_text_collection_count_contains"
  54 external text_count : tree -> string -> int = "caml_text_collection_count"
  55 external text_contains : tree -> string -> [`Text ] node array = "caml_text_collection_contains"
  56 external text_startswith : tree -> string -> [`Text ] node array = "caml_text_collection_startswith"
  57 external text_endswith : tree -> string -> [`Text ] node array = "caml_text_collection_endswith"
  58 external text_equals : tree -> string -> [`Text ] node array = "caml_text_collection_equals"
  59 external text_unsorted_contains : tree -> string -> [`Text ] node array = "caml_text_collection_unsorted_contains"
  60 external text_get_cached_text : tree -> [`Text] node -> string = "caml_text_collection_get_cached_text"
  61
  62 external tree_root : tree -> [`Tree] node = "caml_xml_tree_root"
  63 external tree_subtree_size : tree -> [`Tree] node -> int = "caml_xml_tree_subtree_size"
  64 external tree_subtree_elements : tree -> [`Tree] node -> int = "caml_xml_tree_subtree_elements"
  65
  66 let tree_is_nil x = equal_node x nil
  67
  68 external tree_parent : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent" "noalloc"
  69 external tree_parent_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc" "noalloc"
  70 (*external tree_prev_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_prev_doc" "noalloc" *)
  71 external tree_first_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child" "noalloc"
  72 external tree_closing : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_closing" "noalloc"
  73 external tree_is_open : tree -> [`Tree] node -> bool = "caml_xml_tree_is_open" "noalloc"
  74 external tree_first_element : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_element" "noalloc"
  75 external tree_tagged_child : tree -> [`Tree] node -> Tag.t -> [`Tree] node = "caml_xml_tree_tagged_child" "noalloc"
  76 external tree_next_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling"  "noalloc"
  77 external tree_next_element : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_element"  "noalloc"
  78 external tree_tagged_sibling : tree -> [`Tree] node -> Tag.t -> [`Tree] node = "caml_xml_tree_tagged_sibling" "noalloc"
  79
  80 external tree_prev_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_prev_sibling" "noalloc"
  81 external tree_is_leaf : tree -> [`Tree] node -> bool = "caml_xml_tree_is_leaf" "noalloc"
  82 external tree_last_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_last_child" "noalloc"
  83 external tree_is_first_child : tree -> [`Tree] node -> bool = "caml_xml_tree_is_first_child" "noalloc"
  84
  85
  86 external tree_tag_id : tree -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id"  "noalloc"
  87
  88
  89 let tree_is_last t n = equal_node nil (tree_next_sibling t n)
  90
  91
  92 external tree_my_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text" "noalloc"
  93 external tree_my_text_unsafe : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text_unsafe" "noalloc"
  94 (*external tree_next_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text" "noalloc" *)
  95 external tree_doc_ids : tree -> [`Tree ] node -> [`Text ] node * [`Text ] node = "caml_xml_tree_doc_ids"
  96
  97 let text_size tree = inode (snd ( tree_doc_ids tree root ))
  98
  99 let text_get_cached_text t (x:[`Text] node) =
 100   if x == nulldoc then ""
 101   else
 102      text_get_cached_text t x
 103
 104
 105 external tree_text_xml_id : tree -> [`Text ] node -> int = "caml_xml_tree_text_xml_id" "noalloc"
 106 external tree_node_xml_id : tree -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id" "noalloc"
 107 external tree_is_ancestor : tree -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor" "noalloc"
 108 external tree_tagged_desc : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_desc" "noalloc"
 109 external tree_tagged_foll_below : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_foll_below" "noalloc"
 110 external tree_tagged_foll_before : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_foll_before" "noalloc"
 111 external tree_subtree_tags : tree -> [`Tree ] node -> Tag.t -> int = "caml_xml_tree_subtree_tags" "noalloc"
 112
 113
 114 type unordered_set
 115 external unordered_set_alloc : int -> unordered_set = "caml_unordered_set_alloc"
 116 external unordered_set_length : unordered_set -> int = "caml_unordered_set_length"
 117 external unordered_set_insert : unordered_set -> int -> unit = "caml_unordered_set_set" "noalloc"
 118
 119 external tree_select_child : tree -> [`Tree ] node -> unordered_set -> [`Tree] node = "caml_xml_tree_select_child" "noalloc"
 120 external tree_select_foll_sibling : tree -> [`Tree ] node -> unordered_set -> [`Tree] node = "caml_xml_tree_select_foll_sibling" "noalloc"
 121 external tree_select_desc : tree -> [`Tree ] node -> unordered_set -> [`Tree] node = "caml_xml_tree_select_desc" "noalloc"
 122 external tree_select_foll_below : tree -> [`Tree ] node -> unordered_set -> [`Tree] node -> [`Tree] node = "caml_xml_tree_select_foll_below" "noalloc"
 123 external tree_select_foll_before : tree -> [`Tree ] node -> unordered_set -> [`Tree] node -> [`Tree] node = "caml_xml_tree_select_foll_before" "noalloc"
 124
 125
 126 module HPtset = Hashtbl.Make(Ptset.Int)
 127
 128 let vector_htbl = HPtset.create MED_H_SIZE
 129
 130 let ptset_to_vector s =
 131   try
 132     HPtset.find vector_htbl s
 133   with
 134       Not_found ->
 135         let v = unordered_set_alloc (Ptset.Int.cardinal s) in
 136         let _ = Ptset.Int.iter (fun e -> unordered_set_insert v e) s in
 137           HPtset.add vector_htbl s v; v
 138
 139
 140
 141 let subtree_size t i = tree_subtree_size t.doc i
 142 let subtree_elements t i = tree_subtree_elements t.doc i
 143 let text_size t = text_size t.doc
 144
 145 module MemUnion = Hashtbl.Make (struct
 146       type t = Ptset.Int.t*Ptset.Int.t
 147       let equal (x,y) (z,t) = (Ptset.Int.equal x z)&&(Ptset.Int.equal y t)
 148       let equal a b = equal a b || equal b a
 149       let hash (x,y) =   (* commutative hash *)
 150         let x = Ptset.Int.hash x
 151         and y = Ptset.Int.hash y
 152         in
 153           if x < y then HASHINT2(x,y) else HASHINT2(y,x)
 154     end)
 155
 156 module MemAdd = Hashtbl.Make (
 157   struct
 158     type t = Tag.t*Ptset.Int.t
 159     let equal (x,y) (z,t) = (x == z)&&(Ptset.Int.equal y t)
 160     let hash (x,y) =  HASHINT2(x,Ptset.Int.hash y)
 161   end)
 162
 163 let collect_tags tree =
 164   let h_union = MemUnion.create BIG_H_SIZE in
 165   let pt_cup s1 s2 =
 166       try
 167         MemUnion.find h_union (s1,s2)
 168       with
 169         | Not_found -> let s = Ptset.Int.union s1 s2
 170           in
 171             MemUnion.add h_union (s1,s2) s;s
 172   in
 173   let h_add = MemAdd.create BIG_H_SIZE in
 174   let pt_add t s =
 175     try MemAdd.find h_add (t,s)
 176     with
 177       | Not_found -> let r = Ptset.Int.add t s in
 178           MemAdd.add h_add (t,s) r;r
 179   in
 180   let h = Hashtbl.create BIG_H_SIZE in
 181   let update t sc sb ss sa =
 182     let schild,sbelow,ssibling,safter =
 183       try
 184         Hashtbl.find h t
 185       with
 186         | Not_found ->
 187             (Ptset.Int.empty,Ptset.Int.empty,Ptset.Int.empty,Ptset.Int.empty)
 188     in
 189       Hashtbl.replace h t
 190         (pt_cup sc schild,pt_cup sbelow sb, pt_cup ssibling ss, pt_cup safter sa)
 191   in
 192   let rec loop_right id acc_after =
 193     if  id == nil
 194     then Ptset.Int.empty,Ptset.Int.empty,acc_after
 195     else
 196     let sibling2,desc2,after2 = loop_right (tree_next_sibling tree id) acc_after in
 197     let child1,desc1,after1   = loop_left (tree_first_child tree id) after2  in
 198     let tag = tree_tag_id tree id in
 199     update tag child1 desc1 sibling2 after2;
 200     ( pt_add tag sibling2,
 201       pt_add tag (pt_cup desc1 desc2),
 202       pt_cup after1 (pt_cup desc1 desc2) )
 203   and loop_left id acc_after =
 204     if  id == nil
 205     then Ptset.Int.empty,Ptset.Int.empty,acc_after
 206     else
 207     let sibling2,desc2,after2 = loop_right (tree_next_sibling tree id) acc_after in
 208     let child1,desc1,after1   = loop_left (tree_first_child tree id) after2  in
 209     let tag = tree_tag_id tree id in
 210     update tag child1 desc1 sibling2 after2;
 211     (pt_add tag sibling2,
 212      pt_add tag (pt_cup desc1 desc2),
 213      acc_after )
 214   in
 215   let _ = loop_left (tree_root tree) Ptset.Int.empty in h
 216
 217
 218
 219
 220 let contains_array = ref [| |]
 221 let contains_index = Hashtbl.create 4096
 222 let in_array _ i =
 223   try
 224     Hashtbl.find contains_index i
 225   with
 226       Not_found -> false
 227
 228 let init_textfun f t s =
 229   let a = match f with
 230     | `CONTAINS -> text_contains t.doc s
 231     | `STARTSWITH -> text_startswith t.doc s
 232     | `ENDSWITH -> text_endswith t.doc s
 233     | `EQUALS -> text_equals t.doc s
 234   in
 235     (*Array.fast_sort (compare) a; *)
 236     contains_array := a;
 237     Array.iter (fun x -> Hashtbl.add contains_index x true) !contains_array
 238
 239 let count_contains t s = text_count_contains t.doc s
 240 let unsorted_contains t s = text_unsorted_contains t.doc s
 241
 242 let init_naive_contains t s =
 243   let i,j = tree_doc_ids t.doc (tree_root t.doc)
 244   in
 245   let regexp = Str.regexp_string s in
 246   let matching arg =
 247     try
 248       let _ = Str.search_forward regexp arg 0;
 249       in true
 250     with _ -> false
 251   in
 252   let rec loop n acc l =
 253     if n >= j then acc,l
 254     else
 255       let s = text_get_cached_text t.doc n
 256       in
 257         if matching s
 258         then loop (nodei ((inode n)+1)) (n::acc) (l+1)
 259         else loop (nodei ((inode n)+1)) acc l
 260   in
 261   let acc,l = loop i [] 0 in
 262   let a = Array.create l nulldoc in
 263   let _ = List.fold_left (fun cpt e -> a.(cpt) <- e; (cpt-1)) (l-1) acc
 264   in
 265     contains_array := a
 266
 267 let last_idx = ref 0
 268
 269 let array_find a i j =
 270   let l = Array.length a in
 271   let rec loop idx x y =
 272     if x > y || idx >= l then nulldoc
 273        else
 274          if a.(idx) >= x then if a.(idx) > y then nulldoc else (last_idx := idx;a.(idx))
 275          else loop (idx+1) x y
 276   in
 277     if a.(0) > j || a.(l-1) < i then nulldoc
 278     else loop !last_idx i j
 279
 280 let text_below tree t =
 281   let l = Array.length !contains_array in
 282   let i,j = tree_doc_ids tree.doc t in
 283   let id = if l == 0 then i else (array_find !contains_array i j) in
 284   tree_parent_doc tree.doc id
 285
 286 let text_next tree t root =
 287   let l = Array.length !contains_array in
 288   let inf = nodei((inode(snd(tree_doc_ids tree.doc t)))+1) in
 289   let _,j = tree_doc_ids tree.doc root in
 290   let id = if l == 0 then if inf > j then nulldoc else  inf
 291   else array_find !contains_array inf j
 292   in
 293   tree_parent_doc tree.doc id
 294
 295
 296
 297 module DocIdSet = struct
 298   include Set.Make (struct type t = [`Text] node
 299                            let compare = compare_node end)
 300
 301 end
 302 let is_nil t = t == nil
 303
 304 let is_node t = t != nil
 305 let is_root t = t == root
 306
 307 let node_of_t t  =
 308   let _ = Tag.init (Obj.magic t) in
 309   let table = collect_tags t
 310   in (*
 311   let _ = Hashtbl.iter (fun t (c,d,ns,f) ->
 312                           Printf.eprintf "Tag %s has:\n" (Tag.to_string t);
 313                           Printf.eprintf "Child tags: ";
 314                           Ptset.Int.iter (fun t -> Printf.eprintf "%s "(Tag.to_string t)) c;
 315                           Printf.eprintf "\nDescendant tags: ";
 316                           Ptset.Int.iter (fun t -> Printf.eprintf "%s "(Tag.to_string t)) d;
 317                           Printf.eprintf "\nNextSibling tags: ";
 318                           Ptset.Int.iter (fun t -> Printf.eprintf "%s "(Tag.to_string t)) ns;
 319                           Printf.eprintf "\nFollowing tags: ";
 320                           Ptset.Int.iter (fun t -> Printf.eprintf "%s "(Tag.to_string t)) f;
 321                           Printf.eprintf "\n\n%!";) table
 322   in
 323
 324      *)
 325     { doc= t;
 326       ttable = table;
 327     }
 328
 329 let finalize _ = Printf.eprintf "Release the string list !\n%!"
 330 ;;
 331
 332 let parse f str =
 333   node_of_t
 334     (f str
 335        !Options.sample_factor
 336        !Options.index_empty_texts
 337        !Options.disable_text_collection)
 338
 339 let parse_xml_uri str = parse parse_xml_uri str
 340 let parse_xml_string str =  parse parse_xml_string str
 341
 342
 343 external pool : tree -> Tag.pool = "%identity"
 344
 345 let magic_string = "SXSI_INDEX"
 346 let version_string = "2"
 347
 348 let pos fd =
 349   Unix.lseek fd 0  Unix.SEEK_CUR
 350
 351 let pr_pos fd = Printf.eprintf "At position %i\n%!" (pos fd)
 352
 353 let write fd s =
 354   let sl = String.length s in
 355   let ssl = Printf.sprintf "%020i" sl in
 356     ignore (Unix.write fd ssl 0 20);
 357     ignore (Unix.write fd s 0 (String.length s))
 358
 359 let rec really_read fd buffer start length =
 360   if length <= 0 then () else
 361     match Unix.read fd buffer start length with
 362         0 -> raise End_of_file
 363       | r -> really_read fd buffer (start + r) (length - r);;
 364
 365 let read fd =
 366   let buffer = String.create 20 in
 367   let _ =  really_read fd buffer 0 20 in
 368   let size = int_of_string buffer in
 369   let buffer = String.create size in
 370   let _ =  really_read fd buffer 0 size in
 371     buffer
 372
 373
 374 let save t str =
 375   let fd = Unix.openfile str [ Unix.O_WRONLY;Unix.O_TRUNC;Unix.O_CREAT] 0o644 in
 376   let out_c = Unix.out_channel_of_descr fd in
 377   let _ = set_binary_mode_out out_c true in
 378     output_string out_c magic_string;
 379     output_char out_c '\n';
 380     output_string out_c version_string;
 381     output_char out_c '\n';
 382     Marshal.to_channel out_c t.ttable [ ];
 383     (* we need to move the fd to the correct position *)
 384     flush out_c;
 385     ignore (Unix.lseek fd (pos_out out_c) Unix.SEEK_SET);
 386     tree_save t.doc fd;
 387     close_out out_c
 388 ;;
 389
 390 let load ?(sample=64) ?(load_text=true) str =
 391   let fd = Unix.openfile str [ Unix.O_RDONLY ] 0o644 in
 392   let in_c = Unix.in_channel_of_descr fd in
 393   let _ = set_binary_mode_in in_c true in
 394   let load_table () =
 395     (let ms = input_line in_c in if ms <> magic_string then failwith "Invalid index file");
 396     (let vs = input_line in_c in if vs <> version_string then failwith "Invalid version file");
 397     let table : (Tag.t,(Ptset.Int.t*Ptset.Int.t*Ptset.Int.t*Ptset.Int.t)) Hashtbl.t =
 398       Marshal.from_channel in_c
 399     in
 400     let ntable = Hashtbl.create (Hashtbl.length table) in
 401       Hashtbl.iter (fun k (s1,s2,s3,s4) ->
 402                       let ss1 = Ptset.Int.fold (Ptset.Int.add) s1 Ptset.Int.empty
 403                       and ss2 = Ptset.Int.fold (Ptset.Int.add) s2 Ptset.Int.empty
 404                       and ss3 = Ptset.Int.fold (Ptset.Int.add) s3 Ptset.Int.empty
 405                       and ss4 = Ptset.Int.fold (Ptset.Int.add) s4 Ptset.Int.empty
 406                       in Hashtbl.add ntable k (ss1,ss2,ss3,ss4)
 407                    ) table;
 408       Hashtbl.clear table;
 409       (* The in_channel read a chunk of fd, so we might be after
 410          the start of the XMLTree save file. Reset to the correct
 411          position *)
 412       ntable
 413   in
 414   let _ = Printf.eprintf "\nLoading tag table : " in
 415   let ntable = time (load_table) () in
 416   ignore(Unix.lseek fd (pos_in in_c) Unix.SEEK_SET);
 417   let tree = { doc = tree_load fd load_text sample;
 418                ttable = ntable;}
 419   in close_in in_c;
 420   tree
 421
 422
 423
 424
 425 let tag_pool t = pool t.doc
 426
 427 let compare = compare_node
 428
 429 let equal a b = a == b
 430
 431 let nts = function
 432     -1 -> "Nil"
 433   | i -> Printf.sprintf "Node (%i)"  i
 434
 435 let dump_node t = nts (inode t)
 436
 437 let is_left t n = tree_is_first_child t.doc n
 438
 439
 440
 441 let is_below_right t n1 n2 =
 442   tree_is_ancestor t.doc (tree_parent t.doc n1) n2
 443   && not (tree_is_ancestor t.doc n1 n2)
 444
 445 let is_binary_ancestor t n1 n2 =
 446   let p = tree_parent t.doc n1 in
 447   let fin = tree_closing t.doc p in
 448   n2 > n1 && n2 < fin
 449 (*  (is_below_right t n1 n2) ||
 450     (tree_is_ancestor t.doc n1 n2) *)
 451
 452 let parent t n = tree_parent t.doc n
 453
 454 let first_child t = (); fun n -> tree_first_child t.doc n
 455 let first_element t = (); fun n -> tree_first_element t n
 456
 457 (* these function will be called in two times: first partial application
 458    on the tag, then application of the tag and the tree, then application of
 459    the other arguments. We use the trick to let the compiler optimize application
 460 *)
 461
 462 let tagged_child t tag = () ; fun n -> tree_tagged_child t.doc n tag
 463
 464 let select_child t = fun ts ->
 465   let v = ptset_to_vector ts in ();
 466     fun n -> tree_select_child t.doc n v
 467
 468 let next_sibling t = (); fun n ->  tree_next_sibling t.doc n
 469 let next_element t = (); fun n ->  tree_next_element t n
 470
 471 let tagged_sibling t tag = (); fun n -> tree_tagged_sibling t.doc n tag
 472
 473 let select_sibling t = fun ts ->
 474   let v = (ptset_to_vector ts) in ();
 475     fun n -> tree_select_foll_sibling t.doc n v
 476
 477 let next_sibling_ctx t = (); fun n _ -> tree_next_sibling t.doc n
 478 let next_element_ctx t = (); fun n _ ->  tree_next_element t n
 479 let tagged_sibling_ctx t tag = (); fun n  _ -> tree_tagged_sibling t.doc n tag
 480
 481 let select_sibling_ctx t = fun ts ->
 482   let v = (ptset_to_vector ts) in ();
 483      fun n  _ -> tree_select_foll_sibling t.doc n v
 484
 485 let id t n = tree_node_xml_id t.doc n
 486
 487 let tag t n = if n == nil then Tag.nullt else tree_tag_id t.doc n
 488
 489 let tagged_desc t tag = (); fun n -> tree_tagged_desc t.doc n tag
 490
 491 let select_desc t = fun ts ->
 492   let v = (ptset_to_vector ts) in ();
 493     fun n -> tree_select_desc t.doc n v
 494
 495 let tagged_foll_ctx  t tag = (); fun n ctx -> tree_tagged_foll_below t.doc n tag ctx
 496
 497 let select_foll_ctx t = fun ts ->
 498   let v = (ptset_to_vector ts) in ();
 499     fun n ctx -> tree_select_foll_below t.doc n v ctx
 500
 501 let closing t n = tree_closing t.doc n
 502 let is_open t n = tree_is_open t.doc n
 503 let get_text_id t n = tree_my_text t.doc n
 504
 505 let last_idx = ref 0
 506 let array_find a i j =
 507   let l = Array.length a in
 508   let rec loop idx x y =
 509     if x > y || idx >= l then nil
 510         else
 511           if a.(idx) >= x then if a.(idx) > y then nil else (last_idx := idx;a.(idx))
 512           else loop (idx+1) x y
 513   in
 514     if a.(0) > j || a.(l-1) < i then nil
 515     else loop !last_idx i j
 516
 517
 518
 519   let count t s = text_count t.doc s
 520   let stack = ref []
 521   let init_stack () = stack := []
 522   let push x = stack:= x::!stack
 523   let peek () = match !stack with
 524      p::_ -> p
 525     | _ -> failwith "peek"
 526   let pop () = match !stack with
 527      p::r -> stack:=r; p
 528     | _ -> failwith "pop"
 529
 530   let next t = nodei ( (inode t) + 1 )
 531   let next2 t = nodei ( (inode t) + 2 )
 532   let next3 t = nodei ( (inode t) + 3 )
 533
 534   let print_xml_fast2  =
 535     let _ = init_stack () in
 536     let h = Hashtbl.create MED_H_SIZE in
 537     let tag_str t = try Hashtbl.find h t with
 538        Not_found -> let s = Tag.to_string t in
 539        Hashtbl.add h t s;s
 540     in
 541     let h_att = Hashtbl.create MED_H_SIZE in
 542     let att_str t = try Hashtbl.find h_att t with
 543        Not_found -> let s = Tag.to_string t in
 544       let attname = String.sub s 3 ((String.length s) -3) in
 545       Hashtbl.add h_att t attname;attname
 546     in fun outc tree t ->
 547       let tree = tree.doc in
 548       let fin = tree_closing tree t in
 549       let rec loop_tag t tag =
 550         if t <= fin then
 551         if tree_is_open tree t then
 552         (* opening tag *)
 553         if tag == Tag.pcdata then
 554         begin
 555           output_string outc (text_get_cached_text tree (tree_my_text_unsafe tree t));
 556           loop (next2 t) (* skip closing $ *)
 557         end
 558         else
 559         let tagstr = tag_str tag in
 560         let _ = output_char outc '<';
 561         output_string outc tagstr in
 562         let t' = next t in
 563         if tree_is_open tree t' then
 564         let _ = push tagstr in
 565         let tag' = tree_tag_id tree t' in
 566         if tag' == Tag.attribute then let t'' = loop_attr (next t') 0 in
 567         output_string outc ">"; loop t'' else (output_string outc ">";loop_tag t' tag')
 568         else (* closing with no content *)
 569         let _ = output_string outc "/>" in
 570         loop (next t')
 571         else
 572         begin
 573         (* closing tag *)
 574           output_string outc "</";
 575           output_string outc (pop());
 576           output_char outc '>';
 577           loop (next t);
 578         end
 579       and loop t = loop_tag t (tree_tag_id tree t)
 580       and loop_attr t n =
 581         if tree_is_open tree t then
 582         let attname = att_str (tree_tag_id tree t) in
 583         output_char outc ' ';
 584         output_string outc attname;
 585         output_string outc "=\"";
 586         let t = next t in (* open $@ *)
 587         output_string outc (text_get_cached_text tree (tree_my_text_unsafe tree t));
 588         output_char outc '"';
 589         loop_attr (next3 t) (n+1)
 590         else
 591         next t (* close @ *)
 592       in loop t
 593
 594   let print_xml_fast  =
 595     let h = Hashtbl.create MED_H_SIZE in
 596     let tag_str t = try Hashtbl.find h t with
 597        Not_found -> let s = Tag.to_string t in
 598        Hashtbl.add h t s;s
 599     in
 600     let h_att = Hashtbl.create MED_H_SIZE in
 601     let att_str t = try Hashtbl.find h_att t with
 602        Not_found -> let s = Tag.to_string t in
 603       let attname = String.sub s 3 ((String.length s) -3) in
 604       Hashtbl.add h_att t attname;attname
 605     in fun outc tree t ->
 606     let rec loop ?(print_right=true) t =
 607       if t != nil
 608       then
 609         let tagid = tree_tag_id tree.doc t in
 610           if tagid==Tag.pcdata
 611           then
 612             begin
 613               let tid =  tree_my_text_unsafe tree.doc t in
 614               output_string outc (text_get_cached_text tree.doc tid);
 615               if print_right
 616               then loop (next_sibling tree t);
 617             end
 618           else
 619             let tagstr = tag_str tagid in
 620             let l = first_child tree t
 621             and r = next_sibling tree t
 622             in
 623               output_char outc  '<';
 624               output_string outc tagstr;
 625               if l == nil then output_string outc  "/>"
 626               else
 627                 if (tag tree l) == Tag.attribute then
 628                   begin
 629                     loop_attributes (first_child tree l);
 630                     if (next_sibling tree l) == nil then output_string outc  "/>"
 631                     else
 632                       begin
 633                         output_char outc  '>';
 634                         loop (next_sibling tree l);
 635                         output_string outc  "</";
 636                         output_string outc  tagstr;
 637                         output_char outc '>';
 638                       end;
 639                   end
 640                 else
 641                   begin
 642                     output_char outc  '>';
 643                     loop l;
 644                     output_string outc "</";
 645                     output_string outc tagstr;
 646                     output_char outc '>';
 647                   end;
 648               if print_right then loop r
 649     and loop_attributes a =
 650       if a != nil
 651       then
 652       let attname = att_str (tag tree a) in
 653       let fsa = first_child tree a in
 654       let tid =  tree_my_text_unsafe tree.doc fsa in
 655         output_char outc ' ';
 656         output_string outc attname;
 657         output_string outc "=\"";
 658         output_string outc (text_get_cached_text tree.doc tid);
 659         output_char outc '"';
 660         loop_attributes (next_sibling tree a)
 661     in
 662         loop ~print_right:false t
 663
 664
 665     let print_xml_fast outc tree t =
 666       if (tag tree t) = Tag.document_node then
 667         print_xml_fast outc tree (first_child tree t)
 668       else print_xml_fast outc tree t
 669
 670 let tags_children t tag =
 671   let a,_,_,_ = Hashtbl.find t.ttable tag in a
 672 let tags_below t tag =
 673   let _,a,_,_ = Hashtbl.find t.ttable tag in a
 674 let tags_siblings t tag =
 675   let _,_,a,_ = Hashtbl.find t.ttable tag in a
 676 let tags_after t tag =
 677   let _,_,_,a = Hashtbl.find t.ttable tag in a
 678
 679
 680 let tags t tag = Hashtbl.find t.ttable tag
 681
 682
 683 let rec binary_parent t n =
 684   let r =
 685   if tree_is_first_child t.doc n
 686   then tree_parent t.doc n
 687   else tree_prev_sibling t.doc n
 688   in if tree_tag_id t.doc r = Tag.pcdata then
 689   binary_parent t r
 690   else r
 691
 692 let doc_ids t n = tree_doc_ids t.doc n
 693
 694 let subtree_tags t tag = ();
 695   fun n -> if n == nil then 0 else
 696     tree_subtree_tags t.doc n tag
 697
 698 let get_text t n =
 699   let tid = tree_my_text t.doc n in
 700     if tid == nulldoc then "" else
 701       text_get_cached_text t.doc tid
 702
 703
 704 let dump_tree fmt tree =
 705   let rec loop t n =
 706     if t != nil then
 707       let tag = (tree_tag_id tree.doc t ) in
 708       let tagstr = Tag.to_string tag in
 709         let tab = String.make n ' ' in
 710
 711           if tag == Tag.pcdata || tag == Tag.attribute_data
 712           then
 713             Format.fprintf fmt "%s<%s>%s</%s>\n"
 714               tab tagstr (text_get_cached_text tree.doc (tree_my_text tree.doc t)) tagstr
 715           else begin
 716             Format.fprintf fmt "%s<%s>\n" tab tagstr;
 717             loop (tree_first_child tree.doc t) (n+2);
 718             Format.fprintf fmt "%s</%s>\n%!" tab tagstr;
 719           end;
 720           loop (tree_next_sibling tree.doc t) n
 721   in
 722     loop root 0
 723 ;;
 724
 725
 726 let print_xml_fast3 t = tree_print_xml_fast3 t.doc