Commit 4c7e8431 authored by bguillaum's avatar bguillaum

version 0.25.1:

Fix bug with several constraints on the same node in a "without" part

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8628 7838e531-6607-4d57-9587-6c381814729c
parent b489623a
VERSION = 0.25.0
VERSION = 0.25.1
INSTALL_DIR_LIB = @OCAMLLIB@
INSTALL_DIR = @prefix@/bin/
......
......@@ -220,6 +220,15 @@ module List_ = struct
| None -> opt_map f t
| Some r -> r :: (opt_map f t)
let rec try_map exc fct = function
| [] -> []
| x::t -> let tail = try_map exc fct t in
try (fct x)::tail
with e ->
if e = exc
then tail
else raise e
let rec flat_map f = function
| [] -> []
| x::t -> (f x)@(flat_map f t)
......
......@@ -105,6 +105,8 @@ module List_: sig
val opt_map: ('a -> 'b option) -> 'a list -> 'b list
val try_map: exn -> ('a -> 'b) -> 'a list -> 'b list
val opt_mapi: (int -> 'a -> 'b option) -> 'a list -> 'b list
val flat_map: ('a -> 'b list) -> 'a list -> 'b list
......
......@@ -78,21 +78,23 @@ module P_feature = struct
let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
exception Fail_unif
let unif_value v1 v2 = match (v1, v2) with
| ({cst=Absent;in_param=[]},{cst=Absent;in_param=[]}) -> v1
| ({cst=Absent;in_param=[]},_)
| (_,{cst=Absent;in_param=[]}) -> Error.build "unification failure"
| (_,{cst=Absent;in_param=[]}) -> raise Fail_unif
| ({cst=cst1; in_param=in1}, {cst=cst2; in_param=in2}) ->
let cst = match (cst1, cst2) with
| (Equal l1, Equal l2) ->
(match List_.sort_inter l1 l2 with
| [] -> Error.build "unification failure"
| [] -> raise Fail_unif
| l -> Equal l)
| (Equal l1, Different l2)
| (Different l2, Equal l1) ->
(match List_.sort_diff l1 l2 with
| [] -> Error.build "unification failure"
| [] -> raise Fail_unif
| l -> Equal l)
| (Different l1, Different l2) -> Different (List_.sort_union l1 l2)
| _ -> Error.bug "[P_feature.unif_value] inconsistent match case" in
......@@ -368,6 +370,7 @@ module P_fs = struct
| _ -> Error.bug "[P_fs.match_] several different parameters contraints for the same feature is not implemented" in
loop param (p_fs_wo_pos,g_fs)
exception Fail_unif
let unif fs1 fs2 =
let rec loop = function
| [], fs -> fs
......@@ -379,6 +382,8 @@ module P_fs = struct
(* all remaining case are fn1 = fn2 *)
| ((fn1,v1)::t1, (fn2,v2)::t2) (* when fn1 = fn2 *) ->
try (fn1,P_feature.unif_value v1 v2) :: (loop (t1,t2))
with Error.Build (msg,_) -> Error.build "Feature '%s', %s" fn1 msg
with
| P_feature.Fail_unif -> raise Fail_unif
| Error.Build (msg,_) -> Error.build "Feature '%s', %s" fn1 msg
in loop (fs1, fs2)
end (* module P_fs *)
......@@ -84,8 +84,9 @@ module P_fs: sig
It returns [true] iff [pfs] has no requirement about position ok if the requirement is satisfied. *)
val check_position: ?param:Lex_par.t -> float -> t -> bool
exception Fail_unif
(** [unif fs1 fs2] returns the unification of the two feature structures.
It raises (Error.Build msg) exception in case of Failure.
It raises [Fail_unif] exception in case of Failure.
*)
val unif: t -> t -> t
end (* module P_fs *)
......@@ -107,6 +107,7 @@ module P_graph = struct
}
(* -------------------------------------------------------------------------------- *)
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_extension ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list =
let built_nodes = List.map (P_node.build ?pat_vars) full_node_list in
......@@ -132,9 +133,13 @@ module P_graph = struct
let old_map_without_edges =
List.fold_left
(fun acc (id,node) -> Pid_map.add (Pid.Pos (Array_.dicho_find id pos_table)) node acc)
Pid_map.empty
old_nodes in
(fun acc (id,node) ->
let pid_pos = Pid.Pos (Array_.dicho_find id pos_table) in
try
let old = Pid_map.find pid_pos acc in
Pid_map.add pid_pos (P_node.unif_fs (P_node.get_fs node) old) acc
with Not_found -> Pid_map.add pid_pos node acc
) Pid_map.empty old_nodes in
let ext_map_with_all_edges =
List.fold_left
......
......@@ -169,6 +169,7 @@ module Rule = struct
and (node_name2, feat_name2) = feat_id2 in
Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_neg_basic ?pat_vars ?(locals=[||]) pos_table basic_ast =
let (extension, neg_table) =
P_graph.build_extension ?pat_vars ~locals pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
......@@ -321,7 +322,15 @@ module Rule = struct
(full_param, pat_vars, cmd_vars) in
let (pos, pos_table) = build_pos_basic ~pat_vars ~locals rule_ast.Ast.pos_basic in
let negs = List.map (fun basic_ast -> build_neg_basic ~pat_vars ~locals pos_table basic_ast) rule_ast.Ast.neg_basics in
let (negs,_) =
List.fold_left
(fun (acc,pos) basic_ast ->
try ((build_neg_basic ~pat_vars ~locals pos_table basic_ast) :: acc, pos+1)
with P_fs.Fail_unif ->
Log.fwarning "In rule \"%s\" [%s], the wihtout number %d cannot be satisfied, it is skipped"
rule_ast.Ast.rule_id (Loc.to_string rule_ast.Ast.rule_loc) pos;
(acc, pos+1)
) ([],1) rule_ast.Ast.neg_basics in
{
name = rule_ast.Ast.rule_id;
pattern = (pos, negs);
......@@ -333,7 +342,7 @@ module Rule = struct
let build_pattern pattern_ast =
let (pos, pos_table) = build_pos_basic pattern_ast.Ast.pat_pos in
let negs = List.map (fun basic_ast -> build_neg_basic pos_table basic_ast) pattern_ast.Ast.pat_negs in
let negs = List_.try_map P_fs.Fail_unif (fun basic_ast -> build_neg_basic pos_table basic_ast) pattern_ast.Ast.pat_negs in
(pos, negs)
(* ====================================================================== *)
......
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