[r2002-11-10 22:26:37 by cvscast] Passage au type XML

Original author: cvscast
Date: 2002-11-10 22:26:39+00:00

driver/cduce.ml

@@ -6,7 +6,7 @@ let eval_env = Eval.global_env
 
 let print_norm ppf d = 
   Location.protect ppf 
-    (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
+    (fun ppf -> Types.Print.print_descr ppf (Types.normalize d))
 
 let print_value ppf v =
   Location.protect ppf (fun ppf -> Value.print ppf v)

driver/webiface.ml

@@ -170,7 +170,6 @@ let main (cgi : Netcgi.std_activation) =
       Location.set_source (`String src);
       Load_xml.set_auth false;
       
-      load_state ();
       let ok = Cduce.run ppf input in
       if ok then Format.fprintf ppf "@\nOk.@\n";
       let res = Format.flush_str_formatter () in
@@ -180,8 +179,6 @@ let main (cgi : Netcgi.std_activation) =
 
     let dump src =
       let ppf = Format.str_formatter in
-      load_state ();
-      store_state ();  (* Just touch the file ... *)
 
       Format.fprintf ppf "<b>Environment</b>:@.";
       Cduce.dump_env ppf;
@@ -192,6 +189,8 @@ let main (cgi : Netcgi.std_activation) =
     in
 
     Location.set_viewport `Html;
+    load_state ();
+    store_state ();  (* Just touch the file ... *)
     html_header p;
     let prog = cgi # argument_value "prog" in
     (match cmd with

parser/ast.ml

@@ -31,6 +31,7 @@ and pexpr' =
   (* Data constructors *)
   | Cst of Types.const
   | Pair of pexpr * pexpr
+  | Xml of pexpr * pexpr
   | RecordLitt of (Types.label * pexpr) list
       
   (* Data destructors *)
@@ -61,6 +62,7 @@ and ppat' =
   | And of ppat * ppat * bool
   | Diff of ppat * ppat
   | Prod of ppat * ppat
+  | XmlT of ppat * ppat
   | Arrow of ppat * ppat
   | Record of Types.label * bool * ppat
   | Capture of Patterns.capture

parser/parser.ml

@@ -137,11 +137,10 @@ EXTEND
 	      mk loc (Cst (Types.Atom (Types.AtomPool.mk a)))
 	  | "<"; e = expr LEVEL "no_appl" -> e ];
 	a = expr_attrib_spec; ">"; c = expr ->
-	tuple loc [t;a;c]
+	mk loc (Xml (t, mk loc (Pair (a,c))))
     | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
     | s = STRING2 ->
 	tuple loc (char_list loc s @ [cst_nil])
-(*    | "!"; t = pat -> mk loc (DebugTyper t) *)
     | a = LIDENT -> mk loc (Var a)
     ]
 
@@ -281,7 +280,7 @@ EXTEND
 	| [ "<"; t = pat -> t ]
 	];
 	a = attrib_spec; ">"; c = pat ->
-          multi_prod loc [t;a;c]
+          mk loc (XmlT (t, multi_prod loc [a;c]))
       | s = STRING2 ->
 	  let s = seq_of_string loc s in
 	  let s = List.map 

runtime/eval.ml

@@ -47,6 +47,7 @@ let rec eval env e0 =
 *)
     | Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
     | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
+    | Typed.Xml (e1,e2) -> Xml (eval env e1, eval env e2)
     | Typed.Cst c -> const c
     | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
     | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)

runtime/load_xml.ml

@@ -40,7 +40,7 @@ let run s =
     let att = SortedMap.from_list (fun _ _ -> assert false) att in
     let child = parse_seq () in
     
-    let elt = Pair 
+    let elt = Xml 
 		(Atom (Types.AtomPool.mk name),
 		 Pair (Record att, child)
 		) in

runtime/run_dispatch.ml

@@ -49,6 +49,7 @@ 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.Patterns.Compile.prod
+  | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.xml
   | Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
   | Atom a -> 
       run_disp_basic v (fun t -> Types.Atom.has_atom t a) 

runtime/value.ml

 type t =
   | Pair of t * t
+  | Xml of t * t
   | Record of (Types.label,t) SortedMap.t
   | Atom of Types.atom
   | Integer of Big_int.big_int
@@ -48,10 +49,10 @@ let rec is_str = function
 
 let rec print ppf v =
   if is_str v then Format.fprintf ppf "\"%a\"" print_quoted_str v
-  else if is_xml v then print_xml ppf v
   else if is_seq v then Format.fprintf ppf "[ %a]" print_seq v
   else match v with
     | Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
+    | Xml (x,y)  -> print_xml ppf (x,y)
     | Record l -> Format.fprintf ppf "{%a }" print_record l
     | Atom a ->	Format.fprintf ppf "`%s" (Types.AtomPool.value a)
     | Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
@@ -87,7 +88,7 @@ and print_str ppf = function
       print_seq ppf v
 
 and print_xml ppf = function
-  | Pair(Atom tag, Pair (Record attr,content)) ->
+  | (Atom tag, Pair (Record attr,content)) ->
       Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]" 
       (Types.AtomPool.value tag)
       print_record attr

runtime/value.mli

 type t =
 (* Canonical representation *)
   | Pair of t * t
+  | Xml of t * t
   | Record of (Types.label,t) SortedMap.t
   | Atom of Types.atom
   | Integer of Big_int.big_int

tests/biblio.cd

@@ -18,14 +18,14 @@ type Mix   = <h1>[Mix*]
 
 let fun do_authors ([Author+] -> [Mix*])
  | [ <author>a ] -> a
- | [ <author>a <author>b ] -> a " and, " b
- | [ <author>a; x] -> a ", " (do_authors x);;
+ | [ <author>a <author>b ] -> a @ " and, " @ b
+ | [ <author>a; x] -> a @ ", " @ (do_authors x);;
 
 let fun do_paper (Paper -> <li>[Mix*])
   <paper>[ x::(_* ) <title>t <conference>c <file>f ] ->
 (* Here, type inference says:  x : [Author+] ... *)
     let authors = do_authors x in
-    <li>([ <a href=f>t ] authors "; in " [ <em>c ] "." );;
+    <li>([ <a href=f>t ] @ authors @ "; in " @ [ <em>c ] @ "." );;
 
 let fun do_biblio (Biblio -> Html)
   <bibliography>[ <heading>h; p ] ->

tests/overloading.cd

@@ -26,4 +26,4 @@ let base : Person =
      ]
   ]
 ]
-in sort 3;;
+in sort base;;

types/atoms.ml

@@ -33,6 +33,10 @@ let contains x = function
 let is_empty = function
   | Finite [] -> true
   | _ -> false
+
+let is_atom = function
+  | Finite [a] -> Some a
+  | _ -> None
       
 let sample except = function
   | Finite (x :: _) -> x

types/atoms.mli

@@ -10,6 +10,7 @@ val atom : 'a -> 'a t
 
 val contains : 'a -> 'a t -> bool
 val is_empty : 'a t -> bool
+val is_atom : 'a t -> 'a option
 val sample : ('a list -> 'a) -> 'a t -> 'a
 
 val print : string -> (Format.formatter -> 'a -> unit) -> 'a t -> 

types/patterns.ml

-  let wrap s f x =
-    Printf.eprintf "%s start\n" s; flush stderr;
-    let r = f x in
-    Printf.eprintf "%s stop\n" s; flush stderr;
-    r
-
 type capture = string
 type fv = capture SortedList.t
 
@@ -17,6 +11,7 @@ type d =
   | Cup of descr * descr
   | Cap of descr * descr * bool
   | Times of node * node
+  | Xml of node * node
   | Record of Types.label * node
   | Capture of capture
   | Constant of capture * Types.const
@@ -64,6 +59,8 @@ let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e =
   (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2,e))
 let times x y =
   (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
+let xml x y =
+  (Types.xml x.accept y.accept, SortedList.cup x.fv y.fv, Xml (x,y))
 let record l x = 
   (Types.record l false x.accept, x.fv, Record (l,x))
 let capture x = (Types.any, [x], Capture x)
@@ -101,18 +98,8 @@ let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
 	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
       | Cap ((a1,_,_) as d1, ((a2,_,_) as d2), false) ->
 	  SortedMap.union cup_res (filter_descr a2 d1) (filter_descr a1 d2)
-      | Times (p1,p2) ->
-	  List.fold_left 
-	    (fun accu (d1,d2) ->
-	       let term = 
-		 SortedMap.union times_res 
-		   (filter_node d1 p1) 
-		   (filter_node d2 p2)
-	       in
-	       SortedMap.union cup_res accu term
-	    )
-	    (empty_res fv)
-	    (Types.Product.normal t)
+      | Times (p1,p2) -> filter_prod fv p1 p2 t
+      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
       | Record (l,p) ->
 	  filter_node (Types.Record.project t l) p
       | Capture c ->
@@ -120,6 +107,18 @@ let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
       | Constant (c, cst) ->
 	  [(c, Types.Positive.ty (Types.constant cst))]
 
+and filter_prod ?kind fv p1 p2 t =
+  List.fold_left 
+    (fun accu (d1,d2) ->
+       let term = 
+	 SortedMap.union times_res (filter_node d1 p1) (filter_node d2 p2)
+       in
+       SortedMap.union cup_res accu term
+    )
+    (empty_res fv)
+    (Types.Product.normal ?kind t)
+
+
 and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
   try MemoFilter.find (t,p) !memo_filter
   with Not_found ->
@@ -158,7 +157,9 @@ struct
     a     : Types.descr;
     basic : unit line;
     prod  : (node sl * node sl) line;
-    record: ((Types.label, node sl) sm) line
+    xml   : (node sl * node sl) line;
+    record: ((Types.label, node sl) sm) line;
+
   }
 
   type 'a nline = (result *  'a) list
@@ -173,15 +174,17 @@ struct
     na     : Types.descr;
     nbasic : Types.descr nline;
     nprod  : (nf * nf) nline;
+    nxml   : (nf * nf) nline;
     nrecord: record nline
   }
 
   let empty = { v = []; catchv = []; 
 		a = Types.empty; 
-		basic = []; prod = []; record = [] }
-  let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)
-
-
+		basic = []; prod = []; xml = []; record = [] }
+  let any_basic = Types.neg (List.fold_left Types.cup Types.empty
+			       [Types.Product.any_xml;
+				Types.Product.any;
+				Types.Record.any])
   let restrict t nf =
     let rec filter = function
       | (key,acc) :: rem -> 
@@ -194,6 +197,7 @@ struct
        a = Types.cap t nf.a;
        basic = filter nf.basic;
        prod = filter nf.prod;
+       xml = filter nf.xml;
        record = filter nf.record;
     }
 
@@ -222,6 +226,7 @@ struct
       a = Types.cap nf1.a nf2.a;
       basic = merge merge_basic nf1.basic nf2.basic;
       prod = merge merge_prod nf1.prod nf2.prod;
+      xml = merge merge_prod nf1.xml nf2.xml;
       record = merge merge_record nf1.record nf2.record;
     }
 
@@ -234,6 +239,7 @@ struct
       a = Types.cup nf1.a nf2.a;
       basic = SortedMap.union Types.cup nf1.basic nf2.basic;
       prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
+      xml   = SortedMap.union Types.cup nf1.xml nf2.xml;
       record = SortedMap.union Types.cup nf1.record nf2.record;
     }
 
@@ -246,6 +252,15 @@ struct
 	a = acc;
 	prod = [ (src, ([p], [q])), acc ] }
 
+  let xml acc p q = 
+    let src_p = List.map (fun v -> (v,`Left)) p.fv
+    and src_q = List.map (fun v -> (v,`Right)) q.fv in
+    let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in 
+    { empty with 
+	v = SortedList.cup p.fv q.fv; 
+	a = acc;
+	xml = [ (src, ([p], [q])), acc ] }
+
   let record acc l p =
     let src = List.map (fun v -> (v, `Field l)) p.fv in
     { empty with
@@ -259,6 +274,7 @@ struct
       a = Types.any;
       basic = [ ([],()), any_basic ]; 
       prod  = [ ([],([],[])), Types.Product.any ];
+      xml   = [ ([],([],[])), Types.Product.any_xml ];
       record = [ ([],[]), Types.Record.any ];
     }
 
@@ -269,6 +285,7 @@ struct
       a = Types.any;
       basic = [ (l,()), any_basic ]; 
       prod  = [ (l,([],[])), Types.Product.any  ];
+      xml  = [ (l,([],[])), Types.Product.any_xml  ];
       record = [ (l,[]), Types.Record.any ];
     }
 
@@ -279,6 +296,7 @@ struct
       a = Types.any;
       basic = [ (l,()), any_basic ]; 
       prod  = [ (l,([],[])), Types.Product.any  ];
+      xml   = [ (l,([],[])), Types.Product.any_xml  ];
       record = [ (l,[]), Types.Record.any ];
     }
 
@@ -288,6 +306,7 @@ struct
       a = t;
       basic = [ ([],()), Types.cap t any_basic ];
       prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
+      xml   = [ ([],([],[])), Types.cap t Types.Product.any_xml ];
       record = [ ([],[]), Types.cap t Types.Record.any ];
     }
 
@@ -300,6 +319,7 @@ struct
       | Cap (p,q,_) -> cap (nf p) (nf q)
       | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
       | Times (p,q) -> times acc p q
+      | Xml (p,q) -> xml acc p q
       | Capture x -> capture x
       | Constant (x,c) -> constant x c
       | Record (l,p) -> record acc l p
@@ -310,13 +330,13 @@ struct
     let basic =
       List.map (fun ((res,()),acc) -> (res,acc)) 
 
-    and prod =
+    and prod ?kind l =
       let line accu (((res,(pl,ql)),acc)) =
 	let p = bigcap pl and q = bigcap ql in
 	let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
-	let t = Types.Product.normal acc in
+	let t = Types.Product.normal ?kind acc in
 	List.fold_left aux accu t in
-      List.fold_left line []
+      List.fold_left line [] l
    
 
     and record =
@@ -359,6 +379,7 @@ struct
       na      = nf.a;
       nbasic  = nlines (basic nf.basic);
       nprod   = nlines (prod nf.prod);
+      nxml    = nlines (prod ~kind:`XML nf.xml);
       nrecord = nlines (record nf.record);
     }
 
@@ -373,6 +394,7 @@ struct
   and actions_kind = {
     basic: (Types.descr * result) list;
     prod: result dispatch dispatch;
+    xml: result dispatch dispatch;
     record: record option;
   }
   and record = 
@@ -425,7 +447,7 @@ struct
     in
     aux f a 0
 
-  let combine_kind basic prod record =
+  let combine_kind basic prod xml record =
     try (
       let rs = [] in
       let rs = match basic with
@@ -436,6 +458,10 @@ struct
 	| `None -> rs
 	| `Ignore (`Ignore r) -> r :: rs
 	| _ -> raise Exit in
+      let rs = match xml with
+	| `None -> rs
+	| `Ignore (`Ignore r) -> r :: rs
+	| _ -> raise Exit in
       let rs = match record with
 	| None -> rs
 	| Some (`Result r) -> r :: rs
@@ -448,7 +474,7 @@ struct
 	    -> `Ignore r
 	| _ -> raise Exit
     )
-    with Exit -> `Kind { basic = basic; prod = prod; record = record }
+    with Exit -> `Kind { basic = basic; prod = prod; xml = xml; record = record }
 
   let combine (disp,act) =
     if Array.length act = 0 then `None
@@ -550,7 +576,8 @@ struct
 	| `None -> ()
 	| `Switch (pos, yes, no) -> 
 	    aux (i + 1) ((i,pos) :: accu) yes; aux (i + 1) accu no
-	| `Result (code,t,arity) -> codes.(code) <- (t,arity, accu)
+	| `Result (code,t,arity) -> 
+	    codes.(code) <- (t,arity, accu)
       in
       aux 0 [] iface;
       let res = { id = !cur_id; 
@@ -576,7 +603,8 @@ struct
   let find_code d a =
     let rec aux i = function
       | `Result (code,_,_) -> code
-      | `None -> assert false
+      | `None -> 
+	  assert false
       | `Switch (_,yes,no) ->
 	  match a.(i) with Some _ -> aux (i + 1) yes | None -> aux (i + 1) no
     in
@@ -698,9 +726,13 @@ struct
       (fun x -> x)
 
 
-  let rec dispatch_prod disp =
-    let pl = Array.map (fun p -> p.Normal.nprod) disp.pl in
-    let t = Types.Product.get disp.t in
+  let rec dispatch_prod ?(kind=`Normal) disp =
+    let pl = 
+      match kind with
+	| `Normal ->  Array.map (fun p -> p.Normal.nprod) disp.pl
+	| `XML -> Array.map (fun p -> p.Normal.nxml) disp.pl
+    in
+    let t = Types.Product.get ~kind disp.t in
     get_tests pl
       (fun (res,(p,q)) -> [p, (res,q)], [])
       (Types.Product.pi1 t)
@@ -852,6 +884,7 @@ struct
 	  let a = combine_kind
 		    (dispatch_basic disp)
 		    (dispatch_prod disp)
+		    (dispatch_prod ~kind:`XML disp)
 		    (dispatch_record disp)
 	  in
 	  disp.actions <- Some a;
@@ -925,18 +958,18 @@ struct
    	    )
 	    branches
     in
-    let print_prod  = function
+    let print_prod prefix = function
       | `None -> ()
       | `Ignore d2 ->
-	  Format.fprintf ppf " | (v1,v2) -> @\n";
+	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
 	  print_prod2 d2
       | `TailCall d ->
 	  queue d;
-	  Format.fprintf ppf " | (v1,v2) -> @\n";
+	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
 	  Format.fprintf ppf "      disp_%i v1@\n" d.id
       | `Dispatch (d,branches) ->
 	  queue d;
-	  Format.fprintf ppf " | (v1,v2) -> @\n";
+	  Format.fprintf ppf " | %s(v1,v2) -> @\n" prefix;
 	  Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;
 	  Array.iteri 
 	    (fun code d2 ->
@@ -984,7 +1017,8 @@ struct
     in
     
     List.iter print_basic actions.basic;
-    print_prod actions.prod;
+    print_prod "" actions.prod;
+    print_prod "XML" actions.xml;
     print_record_opt ppf actions.record
 
   let print_actions ppf = function

types/patterns.mli

@@ -16,6 +16,7 @@ val cup    : descr -> descr -> descr
 val cap    : descr -> descr -> bool -> descr
 
 val times  : node -> node -> descr 
+val xml    : node -> node -> descr
 val record : Types.label -> node -> descr
 
 val capture : capture -> descr
@@ -45,6 +46,7 @@ module Compile: sig
   and actions_kind = {
     basic: (Types.descr * result) list;
     prod: result dispatch dispatch;
+    xml: result dispatch dispatch;
     record: record option;
   }
   and record = 

types/types.mli

@@ -39,9 +39,12 @@ val any    : descr
 
 (** Constructors **)
 
+type pair_kind = [ `Normal | `XML ]
+
 val interval : Intervals.t -> descr
 val atom     : atom Atoms.t -> descr
 val times    : node -> node -> descr
+val xml      : node -> node -> descr
 val arrow    : node -> node -> descr
 val record   : label -> bool -> node -> descr
 val char     : Chars.t -> descr
@@ -65,13 +68,14 @@ end
 
 module Product : sig
   val any : descr
-  val other : descr -> descr
-  val is_product : descr -> bool
+  val any_xml : descr
+  val other : ?kind:pair_kind -> descr -> descr
+  val is_product : ?kind:pair_kind -> descr -> bool
 
   (* List of non-empty rectangles *)
   type t = (descr * descr) list
   val is_empty: t -> bool
-  val get: descr -> t
+  val get: ?kind:pair_kind -> descr -> t
   val pi1: t -> descr
   val pi2: t -> descr
     
@@ -81,7 +85,7 @@ module Product : sig
   (* List of non-empty rectangles whose first projection
      are pair-wise disjunct *)
   type normal = t
-  val normal: descr -> normal
+  val normal: ?kind:pair_kind -> descr -> normal
 
   val need_second: t -> bool
     (* Is there more than a single rectangle ? *)
@@ -177,7 +181,8 @@ sig
     | Int of Big_int.big_int
     | Atom of atom
     | Char of Chars.Unichar.t
-    | Pair of t * t
+    | Pair of (t * t)
+    | Xml of (t * t)
     | Record of (label * t) list
     | Fun of (node * node) list
 

typing/typed.ml

@@ -28,6 +28,7 @@ and  texpr' =
   (* Data constructors *)
   | Cst of Types.const
   | Pair of texpr * texpr
+  | Xml of texpr * texpr
   | RecordLitt of (Types.label, texpr) SortedMap.t
       
   (* Data destructors *)

typing/typer.ml

@@ -31,6 +31,7 @@ and descr =
    | `And of ti * ti * bool
    | `Diff of ti * ti
    | `Times of ti * ti
+   | `Xml of ti * ti
    | `Arrow of ti * ti
    | `Record of Types.label * bool * ti
    | `Capture of Patterns.capture
@@ -190,6 +191,7 @@ let rec compile env { loc = loc; descr = d } : ti =
   | And (t1,t2,e) -> cons loc (`And (compile env t1, compile env t2,e))
   | Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))
   | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
+  | XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))
   | Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
   | Record (l,o,t) -> cons loc (`Record (l,o,compile env t))
   | Constant (x,v) -> cons loc (`Constant (x,v))
@@ -213,7 +215,7 @@ let rec comp_fv s =
       | `Or (s1,s2) 
       | `And (s1,s2,_)
       | `Diff (s1,s2)
-      | `Times (s1,s2)
+      | `Times (s1,s2) | `Xml (s1,s2)
       | `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
       | `Record (l,opt,s) -> comp_fv s
       | `Type _ -> ()
@@ -248,6 +250,7 @@ let rec typ seen s : Types.descr =
     | `And (s1,s2,_) ->  Types.cap (typ seen s1) (typ seen s2)
     | `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
     | `Times (s1,s2) ->	Types.times (typ_node s1) (typ_node s2)
+    | `Xml (s1,s2) ->	Types.xml (typ_node s1) (typ_node s2)
     | `Arrow (s1,s2) ->	Types.arrow (typ_node s1) (typ_node s2)
     | `Record (l,o,s) -> Types.record l o (typ_node s)
     | `Capture _ | `Constant _ -> assert false
@@ -290,6 +293,7 @@ and pat_aux seen s = match s.descr' with
   | `Diff _ ->
       raise (Patterns.Error "Difference not allowed in patterns")
   | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
+  | `Xml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
   | `Record (l,false,s) -> Patterns.record l (pat_node s)
   | `Record _ ->
       raise (Patterns.Error "Optional field not allowed in record patterns")
@@ -375,6 +379,9 @@ let rec expr glb { loc = loc; descr = d } =
       |