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