[r2003-03-10 22:35:20 by cvscast] De nouveau rapides, les records

Original author: cvscast
Date: 2003-03-10 22:35:21+00:00

driver/cduce.ml

@@ -39,12 +39,9 @@ let rec print_exn ppf = function
         print_value v
   | Typer.WrongLabel (t,l) ->
       Format.fprintf ppf "Wrong record selection: the label %s@\n" 
-        (Types.LabelPool.value l);
+        (LabelPool.value l);
       Format.fprintf ppf "applied to an expression of type %a@\n"
         print_norm t
-  | Typer.MultipleLabel l ->
-      Format.fprintf ppf "Multiple occurences for the record label %s@\n"
-        (Types.LabelPool.value l);
   | Typer.ShouldHave (t,msg) ->
       Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
         print_norm t

parser/ast.ml

@@ -35,13 +35,13 @@ and pexpr' =
   | Cst of Types.const
   | Pair of pexpr * pexpr
   | Xml of pexpr * pexpr
-  | RecordLitt of (Types.label * pexpr) list
+  | RecordLitt of pexpr label_map
       
   (* Data destructors *)
   | Op of string * pexpr list
   | Match of pexpr * branches
   | Map of pexpr * branches
-  | Dot of (pexpr* Types.label)
+  | Dot of (pexpr* label)
 
   (* Exceptions *)
   | Try of pexpr * branches
@@ -68,7 +68,7 @@ and ppat' =
   | XmlT of ppat * ppat
   | Arrow of ppat * ppat
   | Optional of ppat
-  | Record of bool * (Types.label * ppat) list
+  | Record of bool * ppat label_map
   | Capture of id
   | Constant of id * Types.const
   | Regexp of regexp * ppat

parser/parser.ml

@@ -28,6 +28,8 @@ let rec tuple loc = function
 let tuple_queue = 
   List.fold_right (fun x q -> mk x.loc (Pair (x, q)))
 
+
+
 let char = mk noloc (Internal (Types.char Chars.any))
 let string_regexp = Star (Elem char)
 	       
@@ -44,6 +46,9 @@ let seq_of_string pos s =
 exception Error of string
 let error loc s = raise (Location (loc, Error s))
 
+let make_record loc r =
+  LabelMap.from_list (fun _ _ -> error loc "Duplicated record field") r
+
 let parse_char loc s =
   (* TODO: Unicode *)
   if String.length s <> 1 then
@@ -126,7 +131,7 @@ EXTEND
     ]
     |
     [ e = expr;  "."; l = [LIDENT | UIDENT] -> 
-	mk loc (Dot (e,Types.LabelPool.mk l)) 
+	mk loc (Dot (e,LabelPool.mk l)) 
     ]  
  
     |
@@ -163,7 +168,7 @@ EXTEND
 	  | "<"; e = expr LEVEL "no_appl" -> e ];
 	a = expr_attrib_spec; ">"; c = expr ->
 	mk loc (Xml (t, mk loc (Pair (a,c))))
-    | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
+    | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt LabelMap.empty) ]; "}" -> r
     | s = STRING2 ->
 	tuple loc (char_list loc s @ [cst_nil])
     | a = LIDENT -> mk loc (Var (ident a))
@@ -328,10 +333,9 @@ EXTEND
                   o = [ "?" -> true | -> false]; 
                   x = pat -> 
 		    let x = if o then mk loc (Optional x) else x in
-		    (Types.LabelPool.mk l, x)
+		    (LabelPool.mk l, x)
                 ] SEP ";" ->
-	  (* TODO: check here uniqueness *)
-	  List.sort (fun (l1,_) (l2,_) -> compare l1 l2) r
+	  make_record loc r
       ] ];
   
   char:
@@ -356,15 +360,15 @@ EXTEND
   expr_record_spec:
     [ [ r = LIST1
 	      [ l = [LIDENT | UIDENT]; "="; x = expr -> 
-		  (Types.LabelPool.mk l,x) ] 
+		  (LabelPool.mk l,x) ] 
 	      SEP ";" ->
-	  mk loc (RecordLitt r)
+	  mk loc (RecordLitt (make_record loc r))
       ] ];
   
   expr_attrib_spec:
     [ [ r = expr_record_spec -> r ]
     | [ e = expr LEVEL "no_appl" -> e 
-      | -> mk loc (RecordLitt []) 
+      | -> mk loc (RecordLitt (LabelMap.empty)) 
       ] 
     ];
 END

runtime/eval.ml

@@ -43,10 +43,10 @@ let rec eval env e0 =
 	self
 (* Optimizations:
        - for the non-recursive case, use eval_branches
-       - for the recursive case, could cheat bt pathing self afterwards:
+       - for the recursive case, could cheat by patching self afterwards:
                 (Obj.magic self).(1) <- ....
 *)
-    | Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
+    | Typed.RecordLitt r -> Record (LabelMap.map (eval env) 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
@@ -112,7 +112,7 @@ and eval_concat l1 l2 = match l1 with
   | q -> l2
 
 and eval_dot l = function
-  | Record r -> List.assoc l r
+  | Record r -> LabelMap.assoc l r
   | _ -> assert false
 
 and eval_add x y = match (x,y) with

runtime/load_xml.ml

@@ -6,6 +6,7 @@ open Pxp_yacc
 open Pxp_lexer_types
 open Pxp_types
 open Value
+open Ident
 
 let is_ws s =
   let rec check i = 
@@ -20,8 +21,8 @@ let string s q =
   String (0,String.length s,s,q)
 
 let attrib att = 
-  let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
-  SortedMap.from_list (fun _ _ -> assert false) att
+  let att = List.map (fun (l,v) -> LabelPool.mk l, string v nil) att in
+  LabelMap.from_list (fun _ _ -> assert false) att
 
 let elem tag att child =
   Xml (Atom (Atoms.mk tag), Pair (Record (attrib att), child))

runtime/print_xml.ml

@@ -3,6 +3,7 @@
 open Pxp_aux
 open Pxp_types
 open Value
+open Ident
 
 let exn_print_xml = CDuceExn (Pair (
 				Atom (Atoms.mk "Invalid_argument"),
@@ -43,9 +44,10 @@ let string_of_xml v=
   let rec print_elt = function
     | Xml (Atom tag, Pair (Record attrs, content)) ->
 	let tag = Atoms.value tag in
-	let attrs = List.map (fun (n,v) -> 
-		       if not (is_str v) then raise exn_print_xml;
-		       (Types.LabelPool.value n,get_string v)) attrs in
+	let attrs = LabelMap.mapi_to_list 
+		      (fun n v -> 
+			 if not (is_str v) then raise exn_print_xml;
+			 (LabelPool.value n,get_string v)) attrs in
 	(match content with
 	  | Atom a when a = Sequence.nil_atom -> empty_element tag attrs
 	  | _ ->

runtime/run_dispatch.ml

 (* Running dispatchers *)
 
 open Value
+open Ident
 open Patterns.Compile
 
 let make_result_prod v1 r1 v2 r2 v (code,r) = 
@@ -71,7 +72,7 @@ and run_disp_kind actions v =
   match v with
   | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
   | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
-  | Record r -> run_disp_record false v r actions.record
+  | Record r -> run_disp_record false v (LabelMap.get r) actions.record
   | String (i,j,s,q) -> run_disp_string i j s q actions
   | Atom a -> 
       run_disp_basic v (fun t -> Types.Atom.has_atom t a) actions.basic

runtime/value.ml

+open Ident
+
 type t =
   | Pair of t * t
   | Xml of t * t
-  | Record of (Types.label,t) SortedMap.t
+  | Record of t label_map
   | Atom of Atoms.v
   | Integer of Intervals.v
   | Char of Chars.v
@@ -54,7 +56,7 @@ let rec print ppf 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
+    | Record l -> Format.fprintf ppf "{%a }" print_record (LabelMap.get l)
     | Atom a ->	Atoms.print_v ppf a
     | Integer i -> Intervals.print_v ppf i
     | Char c ->	Chars.print_v ppf c
@@ -94,7 +96,7 @@ and print_xml ppf = function
   | (Atom tag, Pair (Record attr,content)) ->
       Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]" 
       (Atoms.value tag)
-      print_record attr
+      print_record (LabelMap.get attr)
       print_seq content
   | _ -> assert false
 
@@ -104,7 +106,7 @@ and print_record ppf = function
   | f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
 
 and print_field ppf (l,v) = 
-  Format.fprintf ppf "%s=%a" (Types.LabelPool.value l) print v  
+  Format.fprintf ppf "%s=%a" (LabelPool.value l) print v  
 
 
 let normalize = function

runtime/value.mli

+open Ident
+
 type t =
 (* Canonical representation *)
   | Pair of t * t
   | Xml of t * t
-  | Record of (Types.label,t) SortedMap.t
+  | Record of t label_map
   | Atom of Atoms.v
   | Integer of Intervals.v
   | Char of Chars.v

types/ident.ml

@@ -6,3 +6,11 @@ type 'a id_map = (unit,'a) IdMap.map
 type fv = unit IdSet.t
 
 let ident = Id.mk
+
+
+module LabelPool = Pool.Make(SortedList.String)
+module LabelSet = SortedList.Make(SortedList.Lift(LabelPool))
+module LabelMap = LabelSet.Map
+
+type label = LabelPool.t
+type 'a label_map = (unit,'a) LabelMap.map

types/normal.ml

@@ -10,6 +10,8 @@ sig
   val is_empty: t -> bool
 end
 
+type 'a bool = ('a list * 'a list) list
+
 module Make(X1 : S)(X2 : S) =
 struct
   type t = (X1.t * X2.t) list

types/normal.mli

@@ -10,6 +10,7 @@ sig
   val is_empty: t -> bool
 end
 
+type 'a bool = ('a list * 'a list) list
 module Make(X1 : S)(X2 : S) :
 sig
   type t = (X1.t * X2.t) list
@@ -20,10 +21,10 @@ sig
          (t1,t2)  => t1 <> 0, t2 <> 0
     *)
 
-  val boolean_normal: (X1.t * X2.t) Boolean.t -> t
+  val boolean_normal: (X1.t * X2.t) bool -> t
     (* return a normalized form *)
 
-  val boolean: (X1.t * X2.t) Boolean.t -> t
+  val boolean: (X1.t * X2.t) bool -> t
 
   val pi1: t -> X1.t
   val pi2_restricted: X1.t -> t -> X2.t

types/patterns.ml

@@ -9,7 +9,7 @@ type d =
   | Cap of descr * descr
   | Times of node * node
   | Xml of node * node
-  | Record of Types.label * node
+  | Record of label * node
   | Capture of id
   | Constant of id * Types.const
 and node = {
@@ -39,7 +39,7 @@ let rec print ppf (a,_,d) =
 	Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
 	to_print := n1 :: n2 :: !to_print
     | Record (l,n) -> 
-	Format.fprintf ppf "{ %s =  P%i }" (Types.LabelPool.value l) n.id;
+	Format.fprintf ppf "{ %s =  P%i }" (LabelPool.value l) n.id;
 	to_print := n :: !to_print
     | Capture x ->
 	Format.fprintf ppf "%s" (Id.value x)
@@ -188,7 +188,7 @@ module Normal : sig
   type 'a nline = (result *  'a) list
   type record =
     | RecNolabel of result option * result option
-    | RecLabel of Types.label * (nnf * nnf) nline 
+    | RecLabel of label * (nnf * nnf) nline 
   type t = {
     nfv    : fv;
     ncatchv: fv;
@@ -200,8 +200,8 @@ module Normal : sig
   }
 
   val any_basic: Types.descr
-  val first_label: descr -> Types.label
-  val normal: Types.label option -> Types.descr -> node list -> t
+  val first_label: descr -> label
+  val normal: label option -> Types.descr -> node list -> t
 end = 
 struct
   let any_basic = 
@@ -224,7 +224,7 @@ struct
   type 'a nline = (result *  'a) sl
   type record =
     | RecNolabel of result option * result option
-    | RecLabel of Types.label * (nnf * nnf) nline
+    | RecLabel of label * (nnf * nnf) nline
   type t = {
     nfv    : fv;
     ncatchv: fv;
@@ -342,8 +342,8 @@ struct
       | None -> assert false
       | Some label ->
 (*	  Printf.eprintf "[ l = %s; label = %s ]\n" 
-	    (Types.LabelPool.value l)
-	    (Types.LabelPool.value label); *)
+	    (LabelPool.value l)
+	    (LabelPool.value label); *)
 	  assert (label <= l);
 	  if l == label then
 	    let src = IdMap.constant SLeft p.fv in
@@ -434,14 +434,14 @@ struct
 
   let rec first_label (acc,fv,d) =
     if Types.is_empty acc 
-    then Types.LabelPool.dummy_max
+    then LabelPool.dummy_max
     else match d with
       | Constr t -> Types.Record.first_label t
       | Cap (p,q) -> min (first_label p) (first_label q)
       | Cup ((acc1,_,_) as p,q) -> min (first_label p) (first_label q)
 	    (* should "first_label_type acc1" ? *)
       | Record (l,p) -> l
-      | _ -> Types.LabelPool.dummy_max
+      | _ -> LabelPool.dummy_max
 
    
   let remove_catchv n =
@@ -489,7 +489,7 @@ struct
     record: record option;
   }
   and record = 
-    | RecLabel of Types.label * result dispatch dispatch
+    | RecLabel of label * result dispatch dispatch
     | RecNolabel of result option * result option
       
   and 'a dispatch =
@@ -516,7 +516,7 @@ struct
     id : int;
     t  : Types.descr;
     pl : Normal.t array;
-    label : Types.label option;
+    label : label option;
     interface : interface;
     codes : return_code array;
     mutable actions : actions option;
@@ -739,8 +739,8 @@ struct
 	     (fun l p -> min l (Normal.first_label (descr p)))
 	     (min l (Types.Record.first_label ty))
 	     pl
-	) Types.LabelPool.dummy_max !accu in
-    let lab = if lab= Types.LabelPool.dummy_max then None else Some lab in
+	) LabelPool.dummy_max !accu in
+    let lab = if lab= LabelPool.dummy_max then None else Some lab in
 
     let accu = 
       List.map (fun (ty,pl,i,info) -> 
@@ -965,7 +965,7 @@ struct
 	  Format.fprintf ppf "SomeField:%a;NoField:%a" 
 	  print_ret_opt r1 print_ret_opt r2
       | RecLabel (l, d) ->
-	  let l = Types.LabelPool.value l in
+	  let l = LabelPool.value l in
 	  Format.fprintf ppf "check label %s:@\n" l;
 	  Format.fprintf ppf "Present => @[%a@]@\n" (print_prod "record") d
     in
@@ -1024,7 +1024,7 @@ struct
       List.fold_left
 	(fun l p -> min l (Normal.first_label (descr p)))
 	(Types.Record.first_label t) pl in
-    let lab = if lab= Types.LabelPool.dummy_max then None else Some lab in
+    let lab = if lab= LabelPool.dummy_max then None else Some lab in
     
     let pl = Array.of_list 
 	       (List.map (fun p -> Normal.normal lab Types.Record.any_or_absent [p]) pl) in

types/patterns.mli

@@ -15,7 +15,7 @@ val cap    : descr -> descr -> descr
 
 val times  : node -> node -> descr 
 val xml    : node -> node -> descr
-val record : Types.label -> node -> descr
+val record : label -> node -> descr
 
 val capture : id -> descr
 val constant: id -> Types.const -> descr
@@ -56,7 +56,7 @@ module Compile: sig
     record: record option;
   }
   and record =
-    | RecLabel of Types.label * result dispatch dispatch
+    | RecLabel of label * result dispatch dispatch
     | RecNolabel of result option * result option
   and 'a dispatch =
     | Dispatch of dispatcher * 'a array

types/sortedList.ml

@@ -60,8 +60,10 @@ sig
     type ('a,'b) map
     external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
     val empty: ('a,'b) map
+    val iter: ('b -> unit) -> ('a,'b) map -> unit
     val is_empty: ('a,'b) map -> bool
     val singleton: 'a elem -> 'b -> ('a,'b) map
+    val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
     val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
     val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
     val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
@@ -70,6 +72,7 @@ sig
     val map_from_slist: ('a elem -> 'b) -> 'a t -> ('a,'b) map
     val collide: ('b -> 'c -> unit) -> ('a,'b) map -> ('a,'c) map -> unit
     val map: ('b -> 'c) -> ('a,'b) map -> ('a,'c) map
+    val mapi: ('a elem -> 'b -> 'c) -> ('a,'b) map -> ('a,'c) map
     val constant: 'b -> 'a t -> ('a,'b) map
     val num: int -> 'a t -> ('a,int) map
     val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list
@@ -219,6 +222,23 @@ module Map = struct
   let is_empty l = l = []
   let singleton x y = [ (x,y) ]
 
+  let rec iter f = function
+    | (_,y)::l -> f y; iter f l
+    | [] -> ()
+
+  let rec assoc_remove_aux v r = function
+    | ((x,y) as a)::l ->
+	let c = X.compare x v in
+	if c = 0 then (r := y; l) 
+	else if c < 0 then a :: (assoc_remove_aux v r l)
+	else raise Not_found
+    | [] -> raise Not_found
+
+  let assoc_remove v l =
+    let r = ref (Obj.magic 0) in
+    let l = assoc_remove_aux v r l in
+    (!r, l)
+
   let rec merge f l1 l2 =
     match (l1,l2) with
       | ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
@@ -278,6 +298,10 @@ module Map = struct
     | (x,y)::l -> (x, f y)::(map f l)
     | [] -> []
 
+  let rec mapi f = function
+    | (x,y)::l -> (x, f x y)::(mapi f l)
+    | [] -> []
+
   let rec mapi_to_list f = function
     | (x,y)::l -> (f x y) ::(mapi_to_list f l)
     | [] -> []

types/sortedList.mli

@@ -56,8 +56,10 @@ sig
     type ('a,'b) map
     external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
     val empty: ('a,'b) map
+    val iter: ('b -> unit) -> ('a,'b) map -> unit
     val is_empty: ('a,'b) map -> bool
     val singleton: 'a elem -> 'b -> ('a,'b) map
+    val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
     val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
     val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
     val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
@@ -67,6 +69,7 @@ sig
     val map_from_slist: ('a elem -> 'b) -> 'a t -> ('a,'b) map
     val collide: ('b -> 'c -> unit) -> ('a,'b) map -> ('a,'c) map -> unit
     val map: ('b -> 'c) -> ('a,'b) map -> ('a,'c) map
+    val mapi: ('a elem -> 'b -> 'c) -> ('a,'b) map -> ('a,'c) map
     val constant: 'b -> 'a t -> ('a,'b) map
     val num: int -> 'a t -> ('a,int) map
     val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list

types/types.mli

-module LabelPool : Pool.T with type value = string and type t = int
-type label = LabelPool.t
+open Ident
+
 type const = | Integer of Intervals.v
 	     | Atom of Atoms.v 
 	     | Char of Chars.v
@@ -48,7 +48,7 @@ val times    : node -> node -> descr
 val xml      : node -> node -> descr
 val arrow    : node -> node -> descr
 val record   : label -> node -> descr
-val record'  : bool * (label, node) SortedMap.t -> descr
+val record'  : bool * node label_map -> descr
 val char     : Chars.t -> descr
 val constant : const -> descr
 

typing/typed.ml

@@ -30,13 +30,13 @@ and  texpr' =
   | Cst of Types.const
   | Pair of texpr * texpr
   | Xml of texpr * texpr
-  | RecordLitt of (Types.label, texpr) SortedMap.t
+  | RecordLitt of texpr label_map
       
   (* Data destructors *)
   | Op of string * texpr list
   | Match of texpr * branches
   | Map of texpr * branches
-  | Dot of (texpr * Types.label)
+  | Dot of texpr * label
       
   (* Exception *)
   | Try of texpr * branches

typing/typer.ml

@@ -13,10 +13,9 @@ module StringSet = Set.Make(S)
 *)
 
 exception NonExhaustive of Types.descr
-exception MultipleLabel of Types.label
 exception Constraint of Types.descr * Types.descr * string
 exception ShouldHave of Types.descr * string
-exception WrongLabel of Types.descr * Types.label
+exception WrongLabel of Types.descr * label
 exception UnboundId of string
 
 let raise_loc loc exn = raise (Location (loc,exn))
@@ -43,7 +42,7 @@ and descr =
   | IXml of ti * ti
   | IArrow of ti * ti
   | IOptional of ti
-  | IRecord of bool * (Types.label * ti) list
+  | IRecord of bool * ti label_map
   | ICapture of id
   | IConstant of id * Types.const
     
@@ -266,8 +265,7 @@ let rec compile env { loc = loc; descr = d } : ti =
   | XmlT (t1,t2) -> cons loc (IXml (compile env t1, compile env t2))
   | Arrow (t1,t2) -> cons loc (IArrow (compile env t1, compile env t2))
   | Optional t -> cons loc (IOptional (compile env t))
-  | Record (o,r) -> 
-      cons loc (IRecord (o, List.map (fun (l,t) -> l,compile env t) r))
+  | Record (o,r) ->  cons loc (IRecord (o, LabelMap.map (compile env) r))
   | Constant (x,v) -> cons loc (IConstant (x,v))
   | Capture x -> cons loc (ICapture x)
 
@@ -301,7 +299,7 @@ let rec comp_fv s =
 	   | ITimes (s1,s2) | IXml (s1,s2)
 	   | IArrow (s1,s2) -> comp_fv s1; comp_fv s2
 	   | IOptional r -> comp_fv r
-	   | IRecord (_,r) -> List.iter (fun (l,s) -> comp_fv s) r
+	   | IRecord (_,r) -> LabelMap.iter comp_fv r
 	   | IType _ -> ()
 	   | ICapture x
 	   | IConstant (x,_) -> comp_fv_res := IdSet.add x !comp_fv_res
@@ -337,7 +335,7 @@ let rec typ seen s : Types.descr =
     | IOptional s -> Types.Record.or_absent (typ seen s)
     | IRecord (o,r) -> 
 	Types.record' 
-	  (o,List.map (fun (l,s) -> (l,typ_node s)) r)
+	  (o, LabelMap.map typ_node r)
     | ICapture x | IConstant (x,_) -> assert false
 
 and typ_node s : Types.node =
@@ -387,14 +385,13 @@ and pat_aux seen s = match s.descr' with
 	 "Optional field not allowed in record patterns")
   | IRecord (o,r) ->
       let pats = ref [] in
-      let aux (l,s) = 
-	if IdSet.is_empty (fv s) then (l,type_node s)
+      let aux l s = 
+	if IdSet.is_empty (fv s) then type_node s
 	else
-	  ( 
-	    pats := Patterns.record l (pat_node s) :: !pats;
-	    (l,Types.any_node)
-	  ) in
-      let constr = Types.record' (o,List.map aux r) in
+	  ( pats := Patterns.record l (pat_node s) :: !pats;
+	    Types.any_node )
+      in
+      let constr = Types.record' (o,LabelMap.mapi aux r) in
       List.fold_left Patterns.cap (Patterns.constr constr) !pats
 (* TODO: can avoid constr when o=true, and all fields have fv *)
   | ICapture x ->  Patterns.capture x
@@ -491,18 +488,11 @@ let rec expr loc' glb { loc = loc; descr = d } =
 	  (fv,  Typed.Dot (e,l))
       | RecordLitt r -> 
 	  let fv = ref Fv.empty in
-	  let r  = List.sort (fun (l1,_) (l2,_) -> compare l1 l2) r in
-	  let r = List.map 
-		    (fun (l,e) -> 
+	  let r = LabelMap.map 
+		    (fun e -> 
 		       let (fv2,e) = expr loc glb e 
-		       in fv := Fv.cup !fv fv2; (l,e))
+		       in fv := Fv.cup !fv fv2; e)
 		    r in
-	  let rec check = function
-	    | (l1,_) :: (l2,_) :: _ when l1 = l2 -> 
-		raise_loc loc (MultipleLabel l1)
-	    | _ :: rem -> check rem
-	    | _ -> () in
-	  check r;
 	  (!fv, Typed.RecordLitt r)
       | Op (op,le) ->
 	  let (fvs,ltes) = List.split (List.map (expr loc glb) le) in
@@ -636,7 +626,7 @@ and type_check' loc env e constr precise = match e with
 	       raise_loc loc 
 		 (ShouldHave (constr,(Printf.sprintf 
 					"Field %s is not allowed here."
-					(Types.LabelPool.value l)
+					(LabelPool.value l)
 				     )
 			     ));
 	     let t = type_check env e pi true in
@@ -794,10 +784,7 @@ and compute_type' loc env = function
       and t2 = compute_type env e2 in
       Types.times (Types.cons t1) (Types.cons t2)
   | RecordLitt r ->
-      let r =