[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.ml

 open Recursive
 open Printf
-
+open Ident
 
 let map_sort f l =
   SortedList.from_list (List.map f l)
@@ -12,10 +12,6 @@ struct
   let equal = (=)
 end
 
-module LabelPool = Pool.Make(SortedList.String)
-module X = SortedList.Make(SortedList.Lift(LabelPool))
-
-type label = LabelPool.t
 
 type const = 
   | Integer of Intervals.v
@@ -36,7 +32,45 @@ module NodePair = struct
   let hash (x,y) = x.id + 17 * y.id
 end 
 
+module RecArg = struct
+  type 'a t = bool * 'a node0 label_map
+  
+  let rec compare_rec r1 r2 =
+    if r1 == r2 then 0
+    else match (r1,r2) with
+      | (l1,x1)::r1,(l2,x2)::r2 ->
+	  if ((l1:int) < l2) then -1 
+	  else if (l1 > l2) then 1 
+	  else if x1.id < x2.id then -1
+	  else if x1.id > x2.id then 1
+	  else compare_rec r1 r2
+      | ([],_) -> -1
+      | _ -> 1
+
+  let compare (o1,r1) (o2,r2) =
+    if o1 && not o2 then -1 
+    else if o2 && not o1 then 1
+    else compare_rec (LabelMap.get r1) (LabelMap.get r2)
+
+  let rec equal_rec r1 r2 =
+    (r1 == r2) ||
+    match (r1,r2) with
+      | (l1,x1)::r1,(l2,x2)::r2 ->
+	  (x1.id == x2.id) && (l1 == l2) && (equal_rec r1 r2)
+      | _ -> false
+
+  let equal (o1,r1) (o2,r2) =
+    (o1 == o2) && (equal_rec (LabelMap.get r1) (LabelMap.get r2))
+
+  let rec hash_rec accu = function
+    | (l,x)::rem -> hash_rec (257 * accu + 17 * l + x.id) rem
+    | [] -> accu + 5
+      
+  let hash (o,r) = hash_rec (if o then 2 else 1) (LabelMap.get r)
+end
+
 module BoolPair = Boolean.Make(NodePair)
+module BoolRec = Boolean.Make(RecArg)
 
 type descr = {
   atoms : Atoms.t;
@@ -45,7 +79,7 @@ type descr = {
   times : descr BoolPair.t;
   xml   : descr BoolPair.t;
   arrow : descr BoolPair.t;
-  record: (bool * (label, node) SortedMap.t) Boolean.t;
+  record: descr BoolRec.t;
   absent: bool
 } and node = descr node0
 
@@ -54,7 +88,7 @@ let empty = {
   times = BoolPair.empty; 
   xml   = BoolPair.empty; 
   arrow = BoolPair.empty; 
-  record= Boolean.empty;
+  record= BoolRec.empty;
   ints  = Intervals.empty;
   atoms = Atoms.empty;
   chars = Chars.empty;
@@ -65,7 +99,7 @@ let any =  {
   times = BoolPair.full; 
   xml   = BoolPair.full; 
   arrow = BoolPair.full; 
-  record= Boolean.full; 
+  record= BoolRec.full; 
   ints  = Intervals.any;
   atoms = Atoms.any;
   chars = Chars.any;
@@ -78,9 +112,9 @@ let times x y = { empty with times = BoolPair.atom (x,y) }
 let xml x y = { empty with xml = BoolPair.atom (x,y) }
 let arrow x y = { empty with arrow = BoolPair.atom (x,y) }
 let record label t = 
-  { empty with record = Boolean.atom (true,[label,t]) }
-let record' x =
-  { empty with record = Boolean.atom x }
+  { empty with record = BoolRec.atom (true,LabelMap.singleton label t) }
+let record' (x : bool * node Ident.label_map) =
+  {