Commit eea1d6fb authored by Pietro Abate's avatar Pietro Abate

[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
parent a845c226
......@@ -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 ->
......
......@@ -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
......@@ -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
......@@ -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
......@@ -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
......@@ -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
......
......@@ -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;
......
......@@ -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
......
......@@ -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
......
......@@ -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 =
......
......@@ -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
......
......@@ -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) =
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment