Remove trailing white spaces

[SXSI/xpathcomp.git] / tag.ml

diff --git a/tag.ml b/tag.ml
index b692df7..c692e98 100644 (file)
--- a/tag.ml
+++ b/tag.ml
@@ -5,89 +5,63 @@
 (*  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
-let pool = ref HMap.empty
-
-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 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 compare x y = x - y
+type pool
+
+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_get_tag_name"
+
+let nullt = null_tag ()   
+let dummy = nullt
+(* Defined in XMLTree.cpp *)
+let document_node = 0
+let attribute = 1
+let pcdata = 2
+let attribute_data= 3
+let document_node_close = 4
+let attribute_close = 5
+let pcdata_close = 6
+let attribute_data_close= 7
+
+
+let pool = Weak.create 1
+
+let init p = Weak.set pool 0 (Some p)
+
+let get_pool () =  match Weak.get pool 0 with
+  | Some x -> x
+  | None -> failwith "Tag.ml: Uninitialized Document"
+
+let tag s = match s with
+  | "<$>" -> pcdata
+  | "<@>" -> attribute
+  | "" -> document_node
+  | "<@$>" -> attribute_data
+  | _ -> register_tag (get_pool()) s
+
+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
-
-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 compare = String.compare
-  let equal = (=)
-  let print fmt s = Format.fprintf fmt "%s" s
-  external  to_string : t -> string = "%identity"
-
-end
-
-include STag
-let _ = Callback.register "caml_hash_tag" tag
+
+let hash x = x
+
+
+let to_string t = 
+  if t == pcdata then "<$>"
+  else if t == attribute_data then "<@$>"
+  else if t == attribute then "<@>"
+  else if t == nullt then "<!NIL!>"
+  else tag_name (get_pool()) t
+
+
+let print ppf t = Format.fprintf ppf "%s" (to_string t)
+(* Check internal invariants *)
+let check t = 
+  if (t != tag (to_string t))
+  then failwith "module Tag: internal check failed"
+
+let dump = print
+