[r2005-03-15 23:31:43 by afrisch] Namespaces bindings in data model

Original author: afrisch
Date: 2005-03-15 23:31:45+00:00

compile/compile.ml

@@ -68,9 +68,11 @@ and compile_aux env tail = function
   | Typed.Abstraction a -> compile_abstr env a
   | Typed.Cst c -> Const c
   | Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
-  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
+  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) -> 
       Xml (compile env false e1, compile env false e2, compile env tail e3)
-  | Typed.Xml (_,_) -> assert false
+  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) -> 
+      XmlNs (compile env false e1, compile env false e2, compile env tail e3,t)
+  | Typed.Xml _ -> assert false
   | Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r)
   | Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
   | Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
@@ -245,6 +247,10 @@ let namespace (tenv,cenv,codes) pr ns =
   let tenv = Typer.type_ns tenv pr ns in
   (tenv,cenv,codes)
 
+let keep_ns (tenv,cenv,codes) k =
+  let tenv = Typer.type_keep_ns tenv k in
+  (tenv,cenv,codes)
+
 let schema (tenv,cenv,codes) x sch =
   let tenv = Typer.type_schema tenv x sch in
   (tenv,cenv,codes)
@@ -278,6 +284,8 @@ let rec phrases ~run ~show ~loading ~directive =
 	  loop (schema accu name uri) rest
       | { descr = Ast.Namespace (pr,ns) } :: rest ->
 	  loop (namespace accu pr ns) rest
+      | { descr = Ast.KeepNs b } :: rest ->
+	  loop (keep_ns accu b) rest
       | { descr = Ast.Using (x,cu) } :: rest ->
 	  let cu = find_cu accu cu in
 	  loading cu;

compile/lambda.ml

@@ -50,6 +50,7 @@ type expr =
   | Const of Types.Const.t
   | Pair of expr * expr
   | Xml of expr * expr * expr
+  | XmlNs of expr * expr * expr * Ns.table
   | Record of expr label_map
   | String of U.uindex * U.uindex * U.t * expr
 
@@ -164,7 +165,15 @@ module Put = struct
 	bits nbits s 5;
 	expr s e1;
 	expr s e2;
-	expr s e3
+	expr s e3;
+	bool s false
+    | XmlNs (e1,e2,e3,ns) ->
+	bits nbits s 5;
+	expr s e1;
+	expr s e2;
+	expr s e3;
+	bool s true;
+	Ns.serialize_table s ns
     | Record r ->
 	bits nbits s 6;
 	LabelMap.serialize expr s r
@@ -293,7 +302,11 @@ module Get = struct
 	  let e1 = expr s in
 	  let e2 = expr s in
 	  let e3 = expr s in
-	  Xml (e1,e2,e3)
+	  if bool s then
+	    let ns = Ns.deserialize_table s in
+	    XmlNs (e1,e2,e3,ns)
+	  else
+	    Xml (e1,e2,e3)
       | 6 -> Record (LabelMap.deserialize expr s)
       | 7 -> 
 	  let st = U.deserialize s in

compile/lambda.mli

@@ -22,6 +22,7 @@ type expr =
   | Const of Types.Const.t
   | Pair of expr * expr
   | Xml of expr * expr * expr
+  | XmlNs of expr * expr * expr * Ns.table
   | Record of expr label_map
   | String of U.uindex * U.uindex * U.t * expr
 

driver/librarian.ml

@@ -43,7 +43,7 @@ let mk ((typing,compile,code),types,ext) =
     stub = None
   }
 
-let magic = "CDUCE:compunit:00004"
+let magic = "CDUCE:compunit:00005"
 
 let obj_path = ref [ "" ]
 

misc/ns.ml

@@ -3,6 +3,10 @@
    Disallow: namespace xml="..."
 *)
 
+(* TODO:
+   It is very important to hash-cons table when 
+   serializing/deserializing code with many XmlNs literals ... *)
+
 module U = Encodings.Utf8
 let empty_str = U.mk ""
 
@@ -31,36 +35,76 @@ module Table = Map.Make(U)
 
 type table = t Table.t
 
+let empty_table =
+  List.fold_left
+    (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
+    Table.empty
+    ["", empty; "xml", xml_ns]
+
+module TableData = Custom.List(Custom.Pair(U)(U))
+module TableHash = Hashtbl.Make(TableData)
+
+let get_table table : TableData.t =
+  Table.fold (fun prefix ns r -> 
+		let std =
+		  try equal (Table.find prefix empty_table) ns
+		  with Not_found -> false in
+		if std then r else (prefix,value ns)::r) table []
+
+let mk_table =
+  List.fold_left
+    (fun table (pr,ns) -> Table.add pr (mk ns) table)
+    empty_table
+  
+let ser_prop =
+  Serialize.Put.mk_property (fun t -> (ref 0, TableHash.create 17))
+
 let serialize_table s table =
-  Table.iter 
-    (fun prefix ns ->
-       Serialize.Put.bool s true;
-       U.serialize s prefix;
-       P.serialize s ns
-    ) table;
-  Serialize.Put.bool s false
+  let (nb,tbl) = Serialize.Put.get_property ser_prop s in
+  let p = get_table table in
+  try
+    let i = TableHash.find tbl p in
+    Serialize.Put.int s i
+  with Not_found ->
+    let i = !nb in
+    incr nb;
+    TableHash.add tbl p i;
+    Serialize.Put.int s i;
+    TableData.serialize s p
+
+let deser_prop =
+  Serialize.Get.mk_property (fun t -> ref [||])
 
 let deserialize_table s =
-  let rec aux table =
-    if not (Serialize.Get.bool s) then table
-    else
-      let prefix = U.deserialize s in
-      let ns = P.deserialize s in
-      aux (Table.add prefix ns table) 
+  let tbl = Serialize.Get.get_property deser_prop s in
+  let i = Serialize.Get.int s in
+  (if (i >= Array.length !tbl) then
+     let ntbl = Array.create (2 * i + 10) None in
+     Array.blit !tbl 0 ntbl 0 (Array.length !tbl);
+     tbl := ntbl);
+  let p = match !tbl.(i) with
+    | None ->
+	let p = TableData.deserialize s in
+	(!tbl).(i) <- Some p;
+	p
+    | Some p ->
+	p
   in
-  aux Table.empty
+  mk_table p
 
 
 (* TODO: avoid re-inserting the same hint for the same
    namespace ==> otherwise memory leak with load_xml ... *)
 let global_hints = State.ref "Ns.prefixes" (Hashtbl.create 63)
 
-let empty_table =
+
+let def_table =
   List.fold_left
     (fun table (pr,ns) -> Table.add (U.mk pr) ns table)
-    Table.empty
-    ["", empty; "xml", xml_ns; "xsd", xsd_ns; "xsi", xsi_ns]
-     
+    empty_table
+    ["xsd", xsd_ns; "xsi", xsi_ns]
+
+
 let add_prefix pr ns table =
   if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
   Table.add pr ns table
@@ -222,7 +266,7 @@ end
 
 module InternalPrinter =
 struct
-  let p = State.ref "Ns.InternalPrinter" (Printer.printer empty_table)
+  let p = State.ref "Ns.InternalPrinter" (Printer.printer def_table)
 
   let set_table t = 
     p := Printer.printer t

misc/ns.mli

@@ -9,6 +9,7 @@ val mk: Utf8.t -> t
 val mk_ascii: string -> t
 val value: t -> Utf8.t
 val empty : t
+val value: t -> Utf8.t
 
 val xml_ns: t
 
@@ -24,9 +25,12 @@ type table  (* prefix => namespace *)
 val serialize_table: table Serialize.Put.f
 val deserialize_table: table Serialize.Get.f
 val empty_table: table  (* Contains only xml *)
+val def_table: table (* Contains xml,xsd,xsi *)
 val add_prefix: Utf8.t -> t -> table -> table
 val dump_table: Format.formatter -> table -> unit
 
+val get_table: table -> (Utf8.t * Utf8.t) list
+
 val process_start_tag:
   table -> string -> (string * string) list -> 
     table * qname * (qname * Utf8.t) list

parser/ast.ml

@@ -12,6 +12,7 @@ and pmodule_item' =
   | LetDecl of ppat * pexpr
   | FunDecl of pexpr
   | Namespace of U.t * Ns.t
+  | KeepNs of bool
   | Using of U.t * U.t
   | EvalStatement of pexpr
   | Directive of toplevel_directive
@@ -71,6 +72,7 @@ and pexpr =
 
   (* Other *)
   | NamespaceIn of U.t * Ns.t * pexpr
+  | KeepNsIn of bool * pexpr
   | Forget of pexpr * ppat    
   | Check of pexpr * ppat
   | Ref of pexpr * ppat

parser/parser.ml

@@ -146,11 +146,18 @@ EXTEND
     | "schema"; name = IDENT; "="; uri = STRING2 ->
 	protect_op "schema";
         [ mk loc (SchemaDecl (U.mk name, uri)) ]
-    | (name,ns) = namespace_binding ->
-	[ mk loc (Namespace (name, ns)) ]
-    | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
-	let e = exp loc (NamespaceIn (name, ns, e2)) in
-        [ mk loc (EvalStatement (exp loc e)) ]
+    | n = namespace_binding ->
+	let d = match n with
+	    | `Prefix (name,ns) ->  Namespace (name, ns)
+	    | `Keep b -> KeepNs b in
+	[ mk loc d ]
+    | n = namespace_binding; "in"; e2 = expr LEVEL "top" ->
+	let e = 
+	  match n with
+	    | `Prefix (name,ns) -> NamespaceIn (name, ns, e2)
+	    | `Keep b -> KeepNsIn (b,e2)
+	in
+	[ mk loc (EvalStatement (exp loc e)) ]
     | "debug"; d = debug_directive -> [ mk loc (Directive (`Debug d)) ]
     | "#"; IDENT "verbose" -> [ mk loc (Directive `Verbose) ]
     | "#"; IDENT "silent" -> [ mk loc (Directive `Silent) ]
@@ -247,8 +254,10 @@ EXTEND
 	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
     | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
         exp loc (let_in e1 p e2)
-    | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
-	exp loc (NamespaceIn (name, ns, e2))
+    | n = namespace_binding; "in"; e2 = expr LEVEL "top" ->
+	(match n with
+	   | `Prefix (name,ns) -> exp loc (NamespaceIn (name, ns, e2))
+	   | `Keep f -> exp loc (KeepNsIn (f,e2)))
     | e = expr; ":"; p = pat ->
 	exp loc (Forget (e,p))
     | e = expr; ":"; "?"; p = pat ->
@@ -386,14 +395,16 @@ EXTEND
   ];
 	
   namespace_binding: [
-    [ "namespace"; 
-	name = [ name = [ IDENT | keyword ]; "=" ->
-		   ident name
-	       | -> U.mk "" ];
-	uri = STRING2 ->
-	  let ns = Ns.mk (ident uri) in
-	  (name,ns)
-    ]
+    [ "namespace"; r = [
+	[ name = 
+	    [ name = [ IDENT | keyword ]; "=" -> ident name
+	    | -> U.mk "" ];
+	  uri = STRING2 ->
+	    let ns = Ns.mk (ident uri) in
+	    `Prefix (name,ns)
+	| IDENT "on" -> `Keep true
+	| IDENT "off" -> `Keep false ]
+      ] -> r ]
   ];
 
   

runtime/eval.ml

@@ -135,6 +135,11 @@ let rec eval env = function
       let v2 = eval env e2 in
       let v3 = eval env e3 in
       Value.Xml (v1,v2,v3)
+  | XmlNs (e1,e2,e3,ns) -> 
+      let v1 = eval env e1 in
+      let v2 = eval env e2 in
+      let v3 = eval env e3 in
+      Value.XmlNs (v1,v2,v3,ns)
   | Record r -> Value.Record (LabelMap.map (eval env) r)
   | String (i,j,s,q) -> Value.substring_utf8 i j s (eval env q)
   | Match (e,brs) -> eval_branches env brs (eval env e)
@@ -313,6 +318,9 @@ and eval_xtrans_aux env brs acc = function
 		| Value.Xml (tag, attr, child) -> 
 		    let child = eval_xtrans env brs child in
 		    Value.Xml (tag, attr, child)
+		| Value.XmlNs (tag, attr, child, ns) ->
+		    let child = eval_xtrans env brs child in
+		    Value.XmlNs (tag, attr, child, ns)
 		| x -> x in
 	      let acc' = Value.Pair (x, Absent) in
 	      set_cdr acc acc';

runtime/load_xml.ml

@@ -4,6 +4,7 @@ open Value
 open Ident
 open Encodings
 
+let keep_ns = ref true
 
 type buf =
     { mutable buffer : string;
@@ -43,12 +44,15 @@ let attrib att =
   let att = List.map (fun (n,v) -> LabelPool.mk n, string_utf8 v) att in
   LabelMap.from_list (fun _ _ -> failwith "Invalid XML document: uniqueness of attributes") att
 
-let elem (tag_ns,tag) att child =
-  Xml (Atom (Atoms.V.mk tag_ns tag), Record (attrib att), child)
+let elem ns (tag_ns,tag) att child =
+  if !keep_ns then
+    XmlNs (Atom (Atoms.V.mk tag_ns tag), Record (attrib att), child, ns)
+  else
+    Xml (Atom (Atoms.V.mk tag_ns tag), Record (attrib att), child)
 
 type stack = 
   | Element of Value.t * stack
-  | Start of Ns.qname * (Ns.qname * Utf8.t) list * Ns.table * stack
+  | Start of Ns.table * Ns.qname * (Ns.qname * Utf8.t) list * Ns.table * stack
   | String of string * stack
   | Empty
 
@@ -58,9 +62,9 @@ let ns_table = ref Ns.empty_table
 let rec create_elt accu = function
   | String (s,st) -> create_elt (string s accu) st
   | Element (x,st) -> create_elt (Pair (x,accu)) st
-  | Start (name,att,table,st) -> 
-      stack := Element (elem name att accu, st);
-      ns_table := table
+  | Start (ns,name,att,old_table,st) -> 
+      stack := Element (elem ns name att accu, st);
+      ns_table := old_table
   | Empty -> assert false
 
 let start_element_handler name att =
@@ -69,7 +73,7 @@ let start_element_handler name att =
   txt.pos <- 0;
 
   let (table,name,att) = Ns.process_start_tag !ns_table name att in
-  stack := Start (name,att,!ns_table, !stack);
+  stack := Start (table,name,att,!ns_table, !stack);
   ns_table := table
 
 let end_element_handler _ =
@@ -86,8 +90,9 @@ let text_handler = add_string txt
 let xml_parser = ref (fun s -> failwith "No XML parser available")
 
 
-let load_xml s =
+let load_xml ?(ns=false) s =
   try
+    keep_ns := ns;
     !xml_parser s;
     match !stack with
       | Element (x,Empty) -> stack := Empty; x
@@ -102,7 +107,7 @@ let load_html s =
 	if (only_ws data (String.length data)) then q else string data q
     | Nethtml.Element (tag, att, child) -> 
 	let att = List.map (fun (n,v) -> ((Ns.empty, U.mk n), U.mk v)) att in
-	Pair (elem (Ns.empty,U.mk tag) att (val_of_docs child), q)
+	Pair (elem Ns.empty_table (Ns.empty,U.mk tag) att (val_of_docs child), q)
   and val_of_docs = function
     | [] -> nil
     | h::t -> val_of_doc (val_of_docs t) h

runtime/load_xml.mli

-val load_xml: string -> Value.t
+val load_xml: ?ns:bool -> string -> Value.t
 val load_html: string -> Value.t
 
 

runtime/print_xml.ml

@@ -129,7 +129,8 @@ let string_of_xml ~utf8 ns_table v =
   in
 
   let rec register_elt = function
-    | Xml (Atom tag, Record attrs, content) ->
+    | Xml (Atom tag, Record attrs, content) 
+    | XmlNs (Atom tag, Record attrs, content, _) ->
 	List.iter
 	  (fun (n,_) -> Ns.Printer.register_attr printer (LabelPool.value n))
 	  (LabelMap.get attrs);
@@ -146,7 +147,8 @@ let string_of_xml ~utf8 ns_table v =
   register_elt v;
 
   let rec print_elt xmlns = function
-    | Xml (Atom tag, Record attrs, content) ->
+    | Xml (Atom tag, Record attrs, content)
+    | XmlNs (Atom tag, Record attrs, content, _) ->
 	let tag = Atoms.V.value tag in
 	let attrs = LabelMap.mapi_to_list 
 		      (fun n v -> 
@@ -174,7 +176,7 @@ let string_of_xml ~utf8 ns_table v =
     let (s,q) = get_string_utf8 v in
     wds s;
     match q with
-      | Pair (Xml _ as x, q) -> print_elt [] x; print_content q
+      | Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q
       | Atom a when a = Sequence.nil_atom -> ()
       | v -> schema_value ~wds v
   in

runtime/run_dispatch.ml

@@ -190,7 +190,8 @@ let rec run_dispatcher d v =
 and run_disp_kind actions v =
   match v with
   | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
-  | Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
+  | Xml (v1,v2,v3) 
+  | XmlNs (v1,v2,v3,_) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
   | Record r -> run_disp_record false v (LabelMap.get r) actions.record
   | String_latin1 (i,j,s,q) -> 
 (*      run_disp_kind actions (Value.normalize v)  *)
@@ -449,7 +450,8 @@ let rec run_dispatcher d v =
 and run_disp_kind actions v =
   match v with
   | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
-  | Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
+  | Xml (v1,v2,v3) | XmlNs (v1,v2,v3,_) -> 
+      run_disp_prod v v1 (Pair (v2,v3)) actions.xml
   | Record r -> run_disp_record !cursor false v (LabelMap.get r) actions.record
   | String_latin1 (i,j,s,q) ->
       run_disp_kind actions (Value.normalize v)

runtime/value.ml

@@ -4,6 +4,7 @@ open Encodings
 type t =
   | Pair of t * t
   | Xml of t * t * t
+  | XmlNs of t * t * t * Ns.table
   | Record of t label_map
   | Atom of Atoms.V.t
   | Integer of Intervals.V.t
@@ -81,7 +82,7 @@ let rec const = function
 
 let rec inv_const = function
   | Pair (x, y) -> Types.Pair (inv_const x, inv_const y)
-  | Xml (x, y, z) ->
+  | Xml (x, y, z) | XmlNs (x,y,z,_) ->
       Types.Pair (inv_const x, Types.Pair (inv_const y, inv_const z))
   | Record x -> Types.Record (LabelMap.map inv_const x)
   | Atom a -> Types.Atom a
@@ -251,7 +252,7 @@ let rec print ppf v =
   else if is_seq v then Format.fprintf ppf "[ @[<hv>%a@]]" print_seq v
   else  match v with
     | Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
-    | Xml (x,y,z)  -> print_xml ppf x y z
+    | Xml (x,y,z) | XmlNs (x,y,z,_) -> print_xml ppf x y z
     | Record l -> Format.fprintf ppf "{%a }" print_record (LabelMap.get l)
     | Atom a ->	Atoms.V.print_quote ppf a
     | Integer i -> Intervals.V.print ppf i
@@ -334,7 +335,7 @@ let dump_xml ppf v =
     | Pair (x, y) ->
         Format.fprintf ppf "@[<hv1>";
         Format.fprintf ppf "<pair>@,%a@,%a@,</pair>@]" aux x aux y
-    | Xml (x, y, z) ->
+    | Xml (x, y, z) | XmlNs (x,y,z,_) ->
         Format.fprintf ppf "@[<hv1>";
         Format.fprintf ppf "<xml>@,%a@,%a@,%a@,</xml>@]" aux x aux y aux z
     | Record x ->
@@ -389,7 +390,8 @@ let rec compare x y =
       | Pair (x1,x2), Pair (y1,y2) ->
 	  let c = compare x1 y1 in if c <> 0 then c 
 	  else compare x2 y2	    
-      | Xml (x1,x2,x3), Xml (y1,y2,y3) ->
+      | (Xml (x1,x2,x3) | XmlNs (x1,x2,x3,_)), 
+	  (Xml (y1,y2,y3) | XmlNs(y1,y2,y3,_)) ->
 	  let c = compare x1 y1 in if c <> 0 then c 
 	  else let c = compare x2 y2 in if c <> 0 then c 
 	  else compare x3 y3
@@ -451,7 +453,8 @@ let rec compare x y =
       | _, String_utf8 (i,j,s,q)   -> compare x (normalize_string_utf8 i j s q)
 
       | Pair (_,_), _ -> -1 | _, Pair(_,_) -> 1
-      | Xml (_,_,_),_ -> -1 | _, Xml(_,_,_) -> 1
+      | (Xml (_,_,_) | XmlNs (_,_,_,_)),_ -> -1 
+      | _, (Xml(_,_,_) | XmlNs(_,_,_,_)) -> 1
       | Record _,_ -> -1 | _, Record _ -> 1
       | Atom _,_ -> -1 | _, Atom _ -> 1
       | Integer _,_ -> -1 | _, Integer _ -> 1
@@ -476,9 +479,10 @@ let iter_xml pcdata_callback other_callback =
     | v -> raise (Invalid_argument "Value.iter_xml")
   in
   function
-    | Xml (_,_,cont) -> aux cont
+    | Xml (_,_,cont) | XmlNs (_,_,cont,_) -> aux cont
     | _ -> raise (Invalid_argument "Value.iter_xml")
 
+(*
 let map_xml map_pcdata map_other =
   let patch_string_utf8 cont = function
     | String_utf8 (i, j, u, v) when compare v nil = 0 ->
@@ -498,7 +502,7 @@ let map_xml map_pcdata map_other =
   function
     | Xml (tag,attrs,cont) -> Xml (tag, attrs, aux cont)
     | _ -> raise (Invalid_argument "Value.map_xml")
-
+*)
 
 let tagged_tuple tag vl =
   let ct = sequence vl in

runtime/value.mli

@@ -5,6 +5,7 @@ type t =
 (* Canonical representation *)
   | Pair of t * t
   | Xml of t * t * t
+  | XmlNs of t * t * t * Ns.table
   | Record of t label_map
   | Atom of Atoms.V.t
   | Integer of Intervals.V.t
@@ -73,8 +74,10 @@ val mk_ext_ref : Types.t option -> (unit -> t) -> (t -> unit) -> t
   character children; second callback is invoked on other children values *)
 val iter_xml : (U.t -> unit) -> (t -> unit) -> t -> unit
 
+(*
   (* as above for map *)
 val map_xml : (U.t -> U.t) -> (t -> t) -> t -> t
+*)
 
 val concat : t -> t -> t
 val flatten : t -> t

types/builtin.ml

@@ -4,6 +4,9 @@ let eval = ref (fun ppf err s -> assert false)
 
 (* Types *)
 
+let namespaces = 
+  Sequence.star (Types.times (Types.cons string) (Types.cons string))
+
 let types =
   [ 
     "Empty",   Types.empty;
@@ -20,6 +23,7 @@ let types =
     "Bool",    bool;
     "Float",   float;
     "AnyXml",  any_xml;
+    "Namespaces", namespaces;
   ]
 
 let env =
@@ -88,6 +92,12 @@ let exn_float_of =
     Value.Pair (
       Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
       Value.string_latin1 "float_of"))
+let exn_namespaces =
+  Value.CDuceExn (
+    Value.Pair (
+      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
+      Value.string_latin1 "namespaces"))
+
 
 let eval_load_file ~utf8 e =
   Location.protect_op "load_file";
@@ -146,6 +156,12 @@ register_fun "load_xml"
   string_latin1 any_xml
   (fun v -> Location.protect_op "load_xml"; Load_xml.load_xml (Value.get_string_latin1 v));;
   
+register_fun "!load_xml"
+  string_latin1 any_xml
+  (fun v -> Location.protect_op "load_xml"; Load_xml.load_xml ~ns:true
+     (Value.get_string_latin1 v));;
+
+
 register_fun "load_html"
   string_latin1 Sequence.any
   (fun v -> Location.protect_op "load_html"; Load_xml.load_html  (Value.get_string_latin1 v));;
@@ -302,7 +318,18 @@ unary_op_gen "flatten"
 register_fun "raise" any Types.empty
   (fun v -> raise (Value.CDuceExn v));;
 
-
+register_fun "namespaces" any_xml 
+  namespaces
+  (function 
+       Value.XmlNs (_,_,_,ns) ->
+	 Value.sequence_rev 
+	   (List.map 
+	      (fun (pr,ns) ->
+		 Value.Pair (Value.string_utf8 pr,
+			     Value.string_utf8 ns))
+	      (Ns.get_table ns))
+     | Value.Xml _ -> raise exn_namespaces
+     | _ -> assert false);;