(* 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_tag_name"
+
+let nullt = null_tag ()
+(* Defined in XMLTree.cpp *)
+let pcdata = 1
+let attribute = 0
+
+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
+ | _ -> 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 then "<@>"
+ 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
+