Fix stupid bug with Tag indices

[SXSI/xpathcomp.git] / tag.ml

diff --git a/tag.ml b/tag.ml
index 8c77691..e5c3820 100644 (file)
--- a/tag.ml
+++ b/tag.ml
@@ -5,93 +5,35 @@
 (*  Distributed under the terms of the LGPL (see LICENCE)                     *)
 (******************************************************************************)
 (*  maybe utf8 string... *)
-module T =
-struct
-  type t = string
-      
-  (* special tag which denotes attribute nodes, should not be a valid
-     xml tag name *)
-  let attribute = "<@>"
-    (* Likewise for strings *)
-  let pcdata = "<$>"
-    
-  let compare : t -> t -> int = String.compare
-    
-  let hash (s:t) =
-    let rec loop acc = function 
-      | -1 -> acc
-      |  n -> loop (( acc lsl 6 ) + (acc lsl 16) - acc + (Char.code s.[n])) (n-1)
-          
-    in
-      loop 0 ((String.length s)-1)
-       
-  let equal x y = compare x y == 0
-end
 
-module HMap = Map.Make (struct type t = int  let compare x y = x - y end)
 
-module HTag =
-struct
 type t = int
-let attribute =  T.hash T.attribute
-let pcdata = T.hash  T.pcdata
+type pool
 
-let pool = ref HMap.empty
+external null_pool : unit -> pool = "caml_xml_tree_nullt"
+external null_tag : unit -> t = "caml_xml_tree_nullt"
+external register_tag : pool -> string -> t = "caml_xml_tree_register_tag"
+external tag_name : pool -> t -> string = "caml_xml_tree_tag_name"
 
+let nullt = null_tag ()   
+let pcdata = max_int
+let attribute = max_int - 1
 
-let add_pool s =
-  let hash = T.hash s in 
-    pool := HMap.add hash s !pool
-  
-let clear_pool () = 
-  pool := HMap.empty;
-  add_pool "";
-  add_pool T.attribute;
-  add_pool T.pcdata
-  
-let _ = clear_pool ()
+let pool = ref (null_pool ())
 
-let init l = 
-  clear_pool ()
+let init p = pool := p
 
-let tag s = 
-  let hash = T.hash s in
-    try 
-      let s' = HMap.find hash !pool
-      in
-       if s <> s' then 
-         failwith (Printf.sprintf "hash conflict s1=%s, s2=%s, %i" s s' hash)
-       else hash
-    with
-       Not_found -> 
-         add_pool s;
-         hash
+let tag s = match s with
+  | "<$>" -> pcdata
+  | "<@>" -> attribute
+  | _ -> register_tag !pool s
 
-let compare x y = x - y
+let compare = (-)
 let equal = (==)
-let hash t = T.hash t
-let print fmt t = 
-  Format.fprintf fmt "%s" (
-    try 
-      HMap.find t !pool
-    with 
-       Not_found -> failwith (Printf.sprintf "%i not found!" t))
-let to_string x = HMap.find  x !pool
+let to_string t = 
+  if t = pcdata then "<$>"
+  else if t = attribute then "<@>"
+  else tag_name !pool t
 
-end
-module STag =
-struct
-  type t = string
-  let attribute = T.attribute
-  let pcdata = T.pcdata
-  external tag : string -> t = "%identity"
-  external clear_pool : unit -> unit = "%identity"
-  let init _ = ()
-  let compare = String.compare
-  let equal = (=)
-  let print fmt s = Format.fprintf fmt "%s" s
-  external  to_string : t -> string = "%identity"
 
-end
-
-include STag
+let print ppf t = Format.fprintf ppf "%s" (to_string t)