[r2003-03-15 10:59:53 by cvscast] map pour les chars et les atoms

Original author: cvscast
Date: 2003-03-15 10:59:54+00:00

runtime/run_dispatch.ml

@@ -44,6 +44,7 @@ let make_result_char ch (code,r) =
 
 let tail_string i j s q =
   if i + 1 = j then q else String (i + 1,j,s,q)
+
 let make_result_string i j s q r1 r2 (code,r) = 
   let ret = Array.map
     (function
@@ -61,8 +62,7 @@ let make_result_string i j s q r1 r2 (code,r) =
 let rec run_disp_basic v f =  function
   | [(_,r)] -> make_result_basic v r
   | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
-  | _ -> 
-      assert false
+  | _ -> assert false
 
 let dummy_r = [||]
 
@@ -81,10 +81,8 @@ and run_disp_kind actions v =
   | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.xml
   | 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
-  | Char c ->
-      run_disp_basic v (fun t -> Types.Char.has_char t c) actions.basic
+  | Atom a -> make_result_basic v (Atoms.get_map a actions.atoms) 
+  | Char c -> make_result_basic v (Chars.get_map c actions.chars) 
   | Integer i ->
       run_disp_basic v (fun t -> Types.Int.has_int t i) actions.basic
   | Abstraction (iface,_) ->
@@ -164,16 +162,7 @@ and run_disp_string i j s q actions =
 and run_disp_string_char d ch =
   match actions d with
     | AIgnore r -> make_result_char ch r
-    | AKind k -> 
-	let rec aux ch = function
-	  | [(_,r)] -> make_result_char ch r
-	  | (t,r)::rem -> 
-	      if Types.Char.has_char t ch then 
-		make_result_char ch r 
-	      else aux ch rem
-	  | _ -> assert false
-	in
-	aux ch k.basic
+    | AKind k -> make_result_char ch (Chars.get_map ch k.chars) 
 and run_disp_string2 r1 i j s q = function
   | Impossible -> assert false
   | Ignore r -> 

types/atoms.ml

@@ -91,3 +91,45 @@ let equal t1 t2 = match (t1,t2) with
   | _ -> false
   
 
+
+(* TODO: optimize map lookup *)
+type 'a map = (v * 'a) list * 'a option
+
+let mk_map l =
+  let rec find_cofinite = function
+    | (Cofinite _, x)::_ -> Some x
+    | _::rem -> find_cofinite rem
+    | [] -> None
+  in
+  let finites = 
+    List.fold_left 
+      (fun accu -> function
+	 | (Cofinite _, _) -> accu
+	 | (Finite l, x) -> List.fold_left (fun accu a -> (a,x)::accu) accu l)
+      [] l
+  in
+  let finites = 
+    List.sort (fun (a1,_) (a2,_) -> AtomPool.compare a1 a2) finites in
+  (finites, find_cofinite l)
+
+let get_map v (f,def) =
+  let rec aux_def def v = function
+    | [] -> def
+    | (a,x)::rem ->
+	let c = AtomPool.compare a v in
+	if c = 0 then x else
+	  if c < 0 then aux_def def v rem
+	  else def
+  in
+  let rec aux_nodef v = function
+    | [] -> assert false
+    | [a,x] -> x
+    | (a,x)::rem ->
+	let c = AtomPool.compare a v in
+	if c = 0 then x else aux_nodef v rem
+  in
+  match def with
+    | Some def -> aux_def def v f
+    | None -> aux_nodef v f
+
+

types/atoms.mli

@@ -24,3 +24,7 @@ val is_atom : t -> v option
 val sample : t -> v
 
 
+type 'a map
+val mk_map: (t * 'a) list -> 'a map
+val get_map: v -> 'a map -> 'a
+

types/chars.ml

@@ -98,3 +98,24 @@ let print =
 	 if a = 0 && b = max_char then Format.fprintf ppf "Char" else
 	 Format.fprintf ppf "%a--%a" print_v a print_v b
     )
+
+type 'a map = (int * 'a) list
+
+let mk_map l =
+  let m = 
+    List.fold_left 
+      (fun accu (i,x) -> 
+	 List.fold_left (fun accu (a,b) -> (b,x)::accu) accu i) [] l in
+  let m = 
+    List.sort 
+      (fun (b1,x1) (b2,x2) -> 
+	 if (b1 : int) < b2 then -1 else if b1 = b2 then 0 else 1)
+      m in
+  m
+
+let rec get_map c = function
+  | [_,x] -> x
+  | (b,x)::rem -> if (c : int) <= b then x else get_map c rem
+  | [] -> assert false
+
+  

types/chars.mli

@@ -26,3 +26,6 @@ val contains : v -> t -> bool
 val sample : t -> v
 
 
+type 'a map
+val mk_map: (t * 'a) list -> 'a map
+val get_map: v -> 'a map -> 'a

types/patterns.ml

@@ -483,6 +483,8 @@ struct
     | AKind of actions_kind
   and actions_kind = {
     basic: (Types.descr * result) list;
+    atoms: result Atoms.map;
+    chars: result Chars.map;
     prod: result dispatch dispatch;
     xml: result dispatch dispatch;
     record: record option;
@@ -564,8 +566,17 @@ struct
 	    -> AIgnore r
 	| _ -> raise Exit
     )
-    with Exit -> AKind { basic = basic; prod = prod; xml = xml; record = record }
-
+    with Exit -> 
+      AKind 
+      { basic = basic;
+	atoms = 
+	   Atoms.mk_map (List.map (fun (t,r) -> Types.Atom.get t, r) basic);
+	chars = 
+	   Chars.mk_map (List.map (fun (t,r) -> Types.Char.get t, r) basic);
+	prod = prod; 
+	xml = xml; 
+	record = record }
+      
   let combine (disp,act) =
     if Array.length act = 0 then Impossible
     else

types/patterns.mli

@@ -51,6 +51,8 @@ module Compile: sig
     | AKind of actions_kind
   and actions_kind = {
     basic: (Types.descr * result) list;
+    atoms: result Atoms.map;
+    chars: result Chars.map;
     prod: result dispatch dispatch;
     xml: result dispatch dispatch;
     record: record option;

types/sortedList.ml

@@ -70,6 +70,7 @@ sig
     val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
     val diff: ('a,'b) map -> 'a t -> ('a,'b) map
     val from_list: ('b -> 'b -> 'b ) -> ('a elem * 'b) list -> ('a,'b) map
+    val from_list_disj: ('a elem * 'b) list -> ('a,'b) map
     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
@@ -79,6 +80,7 @@ sig
     val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list
     val mapi_to_list: ('a elem -> 'b -> 'c) -> ('a,'b) map -> 'c list
     val assoc: 'a elem -> ('a,'b) map -> 'b
+    val assoc_present:  'a elem -> ('a,'b) map -> 'b
 
     val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
   end
@@ -310,6 +312,19 @@ module Map = struct
       | llist -> mergeall (merge2 llist) in
     mergeall (initlist l)
 
+  let from_list_disj l = 
+    let rec initlist = function
+      | [] -> []
+      | e::rest -> [e] :: initlist rest in
+    let rec merge2 = function
+      | l1::l2::rest -> union_disj l1 l2 :: merge2 rest
+      | x -> x in
+    let rec mergeall = function
+      | [] -> []
+      | [l] -> l
+      | llist -> mergeall (merge2 llist) in
+    mergeall (initlist l)
+
   let rec map_from_slist f = function
     | x::l -> (x,f x)::(map_from_slist f l)
     | [] -> []
@@ -350,6 +365,13 @@ module Map = struct
 	else raise Not_found
     | [] -> raise Not_found
 
+  let rec assoc_present v = function
+    | [(_,y)] -> y
+    | (x,y)::l ->
+	let c = X.compare x v in
+	if c = 0 then y else assoc_present v l
+    | [] -> assert false
+
   let rec compare f l1 l2 =
     if l1 == l2 then 0 
     else match (l1,l2) with

types/sortedList.mli

@@ -66,6 +66,7 @@ sig
     val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
     val diff: ('a,'b) map -> 'a t -> ('a,'b) map
     val from_list: ('b -> 'b -> 'b ) -> ('a elem * 'b) list -> ('a,'b) map
+    val from_list_disj: ('a elem * 'b) list -> ('a,'b) map
 
     val map_from_slist: ('a elem -> 'b) -> 'a t -> ('a,'b) map
     val collide: ('b -> 'c -> unit) -> ('a,'b) map -> ('a,'c) map -> unit
@@ -76,6 +77,7 @@ sig
     val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list
     val mapi_to_list: ('a elem -> 'b -> 'c) -> ('a,'b) map -> 'c list
     val assoc: 'a elem -> ('a,'b) map -> 'b
+    val assoc_present:  'a elem -> ('a,'b) map -> 'b
     val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
   end
 end

types/types.ml

@@ -1491,11 +1491,13 @@ end
 
 module Atom = struct
   let has_atom d a = Atoms.contains a d.atoms
+  let get d = d.atoms
 end
 
 module Char = struct
   let has_char d c = Chars.contains c d.chars
   let any = { empty with chars = Chars.any }
+  let get d = d.chars
 end
 
 let print_stat ppf =

types/types.mli

@@ -164,11 +164,13 @@ end
 
 module Atom : sig
   val has_atom : descr -> Atoms.v -> bool
+  val get: descr -> Atoms.t
 end
 
 module Char : sig
   val has_char : descr -> Chars.v -> bool
   val any : descr
+  val get: descr -> Chars.t
 end
 
 val normalize : descr -> descr

typing/typer.ml

@@ -617,6 +617,7 @@ and type_check' loc env e constr precise = match e with
       type_check_pair ~kind:`XML loc env e1 e2 constr precise
 
   | RecordLitt r ->
+(* try to get rid of precise = true for values of fields *)
       if not (Types.Record.has_record constr) then
 	raise_loc loc (ShouldHave (constr,"but it is a record."));
       let (rconstr,res) =