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