Commit ecaa016e authored by bguillaum's avatar bguillaum
Browse files

Merge branch 'master' into grep

Conflicts:
	src/grew_rule.ml
	src/libgrew_.mli

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8459 7838e531-6607-4d57-9587-6c381814729c
parent 928ac485
Version 0.24 (11/24/14)
* Changes in the interface:
- the "loc" type is abstract and exported (changes the libgrew interface)
* New features:
- use a float in a command "node.feat = 123.456"
- improve checking for consistency between rules and feature domain at GRS loading time
- add the possibility to use parameters in the without part
* Bug fixes:
- take the feature "position" into account when the user chose features to display
- accept colors like "#abc"
* Misc
- add files for Geshi
- code reorganization
- add activate mechanism (untested)
Version 0.23 (2014-06-05)
Please refer to SVN logs
\ No newline at end of file
VERSION = 0.23.1
VERSION = 0.24.0
INSTALL_DIR_LIB = @OCAMLLIB@
INSTALL_DIR = @prefix@/bin/
......
......@@ -93,7 +93,7 @@ module Ast = struct
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
| Param of string (* $ident *)
| Equal_param of string (* $ident *)
| Absent
type u_feature = {
......@@ -186,7 +186,7 @@ module Ast = struct
neg_basics: basic list;
commands: command list;
param: (string list * string list) option;
lp: string list option;
lex_par: string list option;
rule_doc:string list;
rule_loc: Loc.t;
}
......
......@@ -45,7 +45,7 @@ module Ast : sig
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
| Param of string (* $ident *)
| Equal_param of string (* $ident *)
| Absent
type u_feature = {
......@@ -123,7 +123,7 @@ module Ast : sig
neg_basics: basic list;
commands: command list;
param: (string list * string list) option; (* (files, vars) *)
lp: string list option; (* lexical parameters in the file *)
lex_par: string list option; (* lexical parameters in the file *)
rule_doc:string list;
rule_loc: Loc.t;
}
......
......@@ -21,15 +21,15 @@ module Int_map = Map.Make (struct type t = int let compare = Pervasives.compare
module Loc = struct
type t = string * int
let to_string (file,line) = sprintf "(file: %s, line: %d)" (Filename.basename file) line
let file_line f l = (f,l)
let file f = (f, -1)
let to_string (file,line) = sprintf "[file: %s, line: %d]" (Filename.basename file) line
let opt_set_line line = function
| None -> None
| Some (file,_) -> Some (file, line)
let opt_to_string = function
| None -> ""
| Some x -> to_string x
end (* module Loc *)
(* ================================================================================ *)
......@@ -61,6 +61,12 @@ module String_ = struct
let of_float float = Str.global_replace (Str.regexp ",") "." (sprintf "%g" float)
let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)
let rm_peripheral_white s =
s
|> (Str.global_replace (Str.regexp "\\( \\|\t\\)*$") "")
|> (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "")
end (* module String_ *)
(* ================================================================================ *)
......
......@@ -26,6 +26,10 @@ module String_: sig
(* [rm_first_char s] returns the string [s] without the first charater if s is not empty.
If s in empty, the empty string is returned *)
val rm_first_char: string -> string
(* [rm_peripheral_white s] returns the string [s] without any white space ot tab
at the beginning or at the end of the string. *)
val rm_peripheral_white: string -> string
end
......@@ -39,7 +43,10 @@ end
(* ================================================================================ *)
(* [Loc] general module to describe errors location: (file name, line number in file) *)
module Loc: sig
type t = string * int
type t
val file_line: string -> int -> t
val file: string -> t
val opt_set_line: int -> t option -> t option
......@@ -88,7 +95,8 @@ module List_: sig
val set: int -> 'a -> 'a list -> 'a list
(** [pos elt list] return [Some index] if [index] is the smallest position in the [list] equals to [elt]. None is returned if [elt] is not in the [list] *)
(** [pos elt list] return [Some index] if [index] is the smallest position in the [list] equals to [elt].
None is returned if [elt] is not in the [list] *)
val pos: 'a -> 'a list -> int option
val opt_map: ('a -> 'b option) -> 'a list -> 'b list
......
......@@ -50,50 +50,90 @@ end (* module G_feature *)
module P_feature = struct
(* feature= (feature_name, disjunction of atomic values) *)
type v =
| Equal of value list (* with Equal constr, the list MUST never be empty *)
| Different of value list
| Param of int
type cst =
| Absent
| Equal of value list (* with Equal constr, the list MUST never be empty *)
| Different of value list
(* NB: in the current version, |in_param| ≤ 1 *)
type v = {
cst: cst;
in_param: int list; (* the list of parameters to which the value must belong *)
}
type t = string * v
let dump (feature_name, {cst; in_param}) =
printf "[P_feature.dump]\n";
printf "%s%s\n"
feature_name
(match cst with
| Different [] -> "=*"
| Different l -> "≠" ^ (String.concat "|" (List.map string_of_value l))
| Equal l -> "=" ^ (String.concat "|" (List.map string_of_value l))
| Absent -> " must be Absent!");
printf "in_param=[%s]\n" (String.concat "," (List.map string_of_int in_param));
printf "%!"
let get_name = fst
let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
let unif_value v1 v2 =
match (v1, v2) with
| (Equal l1, Equal l2) ->
(match List_.sort_inter l1 l2 with
| [] -> Error.build "Unification failure"
| l -> Equal l)
| (Different l1, Different l2) -> Different (List_.sort_union l1 l2)
| _ -> Error.build "cannot unify heterogeneous pattern features"
let to_string ?param_names = function
| (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, Different []) -> sprintf "%s=*" feat_name
| (feat_name, Different atoms) -> sprintf "%s<>%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, Absent) -> sprintf "!%s" feat_name
| (feat_name, Param index) ->
match param_names with
| None -> sprintf "%s=$%d" feat_name index
| Some (l,_) -> sprintf "%s=%s" feat_name (List.nth l index)
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=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"
| l -> Equal l)
| (Equal l1, Different l2)
| (Different l2, Equal l1) ->
(match List_.sort_diff l1 l2 with
| [] -> Error.build "unification failure"
| l -> Equal l)
| (Different l1, Different l2) -> Different (List_.sort_union l1 l2)
| _ -> Error.bug "[P_feature.unif_value] inconsistent match case" in
let (in_) = match (in1,in2) with
| (_,[]) -> (in1)
| ([],_) -> (in2)
| _ -> Error.build "more than one parameter constraint for the same feature in not yet implemented" in
{cst; in_param=in_}
let to_string ?param_names t =
let param_string index = match param_names with
| None -> sprintf "$%d" index
| Some (l,_) -> sprintf "%s" (List.nth l index) in
match t with
| (feat_name, {cst=Absent ;in_param=[]}) -> sprintf "!%s" feat_name
| (feat_name, {cst=Equal atoms;in_param=[]}) -> sprintf "%s=%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, {cst=Different [];in_param=[]}) -> sprintf "%s=*" feat_name
| (feat_name, {cst=Different atoms;in_param=[]}) -> sprintf "%s≠%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, {cst=Equal atoms;in_param=[one_in]}) -> sprintf "%s=%s=$%s" feat_name (List_.to_string string_of_value "|" atoms) (param_string one_in)
| (feat_name, {cst=Different [];in_param=[one_in]}) -> sprintf "%s=$%s" feat_name (param_string one_in)
| (feat_name, {cst=Different atoms;in_param=[one_in]}) -> sprintf "%s≠%s^%s=%s" feat_name (List_.to_string string_of_value "|" atoms) feat_name (param_string one_in)
| _ -> Error.bug "[P_feature.to_string] multiple parameters are not handled"
let build ?pat_vars = function
| ({Ast.kind=Ast.Absent; name=name}, loc) -> (name, {cst=Absent;in_param=[];})
| ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
let values = Domain.build ~loc name unsorted_values in (name, Equal values)
let values = Domain.build ~loc name unsorted_values in (name, {cst=Equal values;in_param=[];})
| ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
let values = Domain.build ~loc name unsorted_values in (name, Different values)
| ({Ast.kind=Ast.Absent; name=name}, loc) -> (name, Absent)
| ({Ast.kind=Ast.Param var; name=name}, loc) ->
match pat_vars with
| None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
| Some l ->
match List_.pos var l with
| Some index -> (name, Param index)
| None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
let values = Domain.build ~loc name unsorted_values in (name, {cst=Different values;in_param=[];})
| ({Ast.kind=Ast.Equal_param var; name=name}, loc) ->
begin
match pat_vars with
| None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
| Some l ->
match List_.pos var l with
| Some index -> (name, {cst=Different []; in_param = [index]})
| None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
end
end (* module P_feature *)
(* ================================================================================ *)
......@@ -200,9 +240,6 @@ module G_fs = struct
| "" -> ""
| s -> sprintf "<TABLE BORDER=\"0\" CELLBORDER=\"0\" CELLSPACING=\"0\">\n%s\n</TABLE>\n" s
let to_word ?main_feat t =
match get_main ?main_feat t with
| (None, _) -> "#"
......@@ -259,7 +296,7 @@ end (* module G_fs *)
(* ================================================================================ *)
module P_fs = struct
(* list are supposed to be striclty ordered wrt compare*)
(* list are supposed to be striclty ordered wrt compare *)
type t = P_feature.t list
let empty = []
......@@ -267,13 +304,10 @@ module P_fs = struct
let check_position ?param position t =
try
match List.assoc "position" t with
| P_feature.Equal pos_list -> List.mem (Float position) pos_list
| P_feature.Different pos_list -> not (List.mem (Float position) pos_list)
| P_feature.Absent -> false
| P_feature.Param index ->
match param with
| Some p -> float_of_string (Lex_par.get_param_value index p) = position
| None -> Log.bug "[P_fs.check_position] Illegal parametrized pattern feature"; exit 2
| {P_feature.cst=P_feature.Equal pos_list; in_param=[]} -> List.mem (Float position) pos_list
| {P_feature.cst=P_feature.Different pos_list; in_param=[]} -> not (List.mem (Float position) pos_list)
| {P_feature.cst=P_feature.Absent} -> false
| _ -> Error.bug "Position can't be parametrized"
with Not_found -> true
let build ?pat_vars ast_fs =
......@@ -294,63 +328,45 @@ module P_fs = struct
exception Fail
let match_ ?param pattern fs =
let pattern_wo_pos =
try List.remove_assoc "position" pattern
with Not_found -> pattern in
let match_ ?param p_fs g_fs =
let p_fs_wo_pos =
try List.remove_assoc "position" p_fs
with Not_found -> p_fs in
let rec loop acc = function
| [], _ -> acc
(* a feature_name present only in instance -> Skip it *)
| ((fn_pat, fv_pat)::t_pat, (fn, _)::t) when fn_pat > fn -> loop acc ((fn_pat, fv_pat)::t_pat, t)
(* Three next cases: pattern requires for the absence of a feature. case 1&2: OK, go on, 3: fail *)
| ((fn_pat, P_feature.Absent)::t_pat, []) -> loop acc (t_pat, [])
| ((fn_pat, P_feature.Absent)::t_pat, (fn, fa)::t) when fn_pat < fn -> loop acc (t_pat, (fn, fa)::t)
| ((fn_pat, P_feature.Absent)::t_pat, (fn, fa)::t) when fn_pat = fn -> raise Fail
(* Two next cases: p_fs requires for the absence of a feature -> OK *)
| ((fn_pat, {P_feature.cst=P_feature.Absent})::t_pat, []) -> loop acc (t_pat, [])
| ((fn_pat, {P_feature.cst=P_feature.Absent})::t_pat, (fn, fa)::t) when fn_pat < fn -> loop acc (t_pat, (fn, fa)::t)
(* Two next cases: each feature_name present in pattern must be in instance: [] means unif failure *)
(* Two next cases: each feature_name present in p_fs must be in instance: [] means unif failure *)
| _, [] -> raise Fail
| ((fn_pat, _)::_, (fn, _)::_) when fn_pat < fn -> raise Fail
(* Next cases: fn_pat = fn *)
| ((_, (P_feature.Equal fv))::t_pat, (_, fa)::t) when List_.sort_mem fa fv -> loop acc (t_pat,t)
| ((_, (P_feature.Different fv))::t_pat, (_, fa)::t) when not (List_.sort_mem fa fv) -> loop acc (t_pat,t)
| ((_, (P_feature.Param index))::t_pat, (_, atom)::t) ->
(match acc with
| None -> Log.bug "[P_fs.compatible] Illegal parametrized pattern feature"; exit 2
| Some param ->
(match Lex_par.filter index (string_of_value atom) param with
| ((_, {P_feature.cst=cst; P_feature.in_param=in_param})::t_pat, (_, atom)::t) ->
(* check for the constraint part and fail if needed *)
let () = match cst with
| P_feature.Absent -> raise Fail
| P_feature.Equal fv when not (List_.sort_mem atom fv) -> raise Fail
| P_feature.Different fv when List_.sort_mem atom fv -> raise Fail
| _ -> () in
(* if constraint part don't fail, look for lexical parameters *)
match (acc, in_param) with
| (_,[]) -> loop acc (t_pat,t)
| (None,_) -> Log.bug "[P_fs.match_] Parametrized constraint in a non-parametrized rule"; exit 2
| (Some param, [index]) ->
(match Lex_par.select index (string_of_value atom) param with
| None -> raise Fail
| Some new_param -> loop (Some new_param) (t_pat,t)
)
)
(* remaining cases: Equal and not list_mem | Diff and not list_mem -> fail*)
| _ -> raise Fail
in loop param (pattern_wo_pos,fs)
let filter fs_p fs_g =
let rec loop = function
| [], fs -> true
| ((fn1,_)::_ as f1, (fn2,_)::t2) when fn1 > fn2 -> loop (f1, t2)
| ((fn1,P_feature.Absent)::t1, []) -> loop (t1,[])
| ((fn1,P_feature.Absent)::t1, ((fn2,_)::_ as f2)) when fn1 < fn2 -> loop (t1,f2)
| ((fn1,P_feature.Absent)::t1, (fn2,_)::_) when fn1 = fn2 -> false
| fs, [] -> false
| ((fn1,_)::_, (fn2,_)::_) when fn1 < fn2 -> false
(* all remaining case are fn1 = fn2 *)
| ((_, (P_feature.Equal fv))::t1, (_, atom)::t2) when List_.sort_mem atom fv -> loop (t1, t2)
| ((_, (P_feature.Different fv))::t1, (_, atom)::t2) when not (List_.sort_mem atom fv) -> loop (t1, t2)
| _ -> false
in loop (fs_p, fs_g)
)
| _ -> 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)
let unif fs1 fs2 =
let rec loop = function
......@@ -361,6 +377,8 @@ module P_fs = struct
| ((fn1,v1)::t1, (fn2,v2)::t2) when fn1 > fn2 -> (fn2,v2) :: (loop ((fn1,v1)::t1,t2))
(* all remaining case are fn1 = fn2 *)
| ((fn1,v1)::t1, (fn2,v2)::t2) (* when fn1 = fn2 *) -> (fn1,P_feature.unif_value v1 v2) :: (loop (t1,t2))
| ((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
in loop (fs1, fs2)
end
end (* module P_fs *)
......@@ -74,7 +74,7 @@ module P_fs: sig
exception Fail
(** [match_ ?param t gfs] tries to match the pattern fs [pfs] with the graph fs [gfs]
(** [match_ ?param p_fs g_fs] tries to match the pattern fs [p_fs] with the graph fs [g_fs].
If [param] is [None], it returns [None] if matching succeeds and else raise [Fail].
If [param] is [Some p], it returns [Some p'] if matching succeeds and else raise [Fail].
*)
......@@ -84,7 +84,8 @@ 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
val filter: t -> G_fs.t -> bool
(** [unif fs1 fs2] returns the unification of the two feature structures.
It raises (Error.Build msg) exception in case of Failure.
*)
val unif: t -> t -> t
end (* module P_fs *)
......@@ -60,7 +60,10 @@ module P_graph = struct
let rec insert (ast_node, loc) = function
| [] -> [P_node.build ?pat_vars (ast_node, loc)]
| (node_id,fs)::tail when ast_node.Ast.node_id = node_id ->
(node_id, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) fs) :: tail
begin
try (node_id, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) fs) :: tail
with Error.Build (msg,_) -> raise (Error.Build (msg,Some loc))
end
| head :: tail -> head :: (insert (ast_node, loc) tail) in
let (named_nodes : (Id.name * P_node.t) list) =
......@@ -104,9 +107,9 @@ module P_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let build_extension ?(locals=[||]) pos_table full_node_list full_edge_list =
let build_extension ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list =
let built_nodes = List.map P_node.build full_node_list in
let built_nodes = List.map (P_node.build ?pat_vars) full_node_list in
let (old_nodes, new_nodes) =
List.partition
......
......@@ -60,6 +60,7 @@ module P_graph: sig
(t * Id.table)
val build_extension:
?pat_vars: string list ->
?locals: Label.decl array ->
Id.table ->
Ast.node list ->
......
......@@ -80,7 +80,7 @@ module Html_doc = struct
sprintf "!%s" u_feature.Ast.name
| Ast.Disequality values ->
sprintf "%s<>%s" u_feature.Ast.name (List_.to_string (fun x->x) "|" values)
| Ast.Param index ->
| Ast.Equal_param index ->
sprintf "%s=%s" u_feature.Ast.name index
let buff_html_node buff (u_node,_) =
......@@ -275,7 +275,7 @@ module Html_doc = struct
wnl "<h6>Lexical parameters</h6>";
(* output local lexical parameters (if any) *)
(match rule_.Ast.lp with
(match rule_.Ast.lex_par with
| None -> ()
| Some lines ->
wnl "<b>Local parameters</b><br/>";
......
......@@ -70,7 +70,10 @@ module P_node: sig
val get_fs: t -> P_fs.t
val get_next: t -> P_edge.t Massoc_pid.t
(** [unif_fs fs t] replaces the feature structure of the node by node.fs unif fs *)
(** [unif_fs fs t] replaces the feature structure of the node
by the unification of [node.fs] ] and [fs].
It raises (Error.Build msg) exception in case of Failure.
*)
val unif_fs: P_fs.t -> t -> t
val build: ?pat_vars: string list -> Ast.node -> (Id.name * t)
......
......@@ -169,9 +169,9 @@ module Rule = struct
and (node_name2, feat_name2) = qfn2 in
Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
let build_neg_basic ?(locals=[||]) pos_table basic_ast =
let build_neg_basic ?pat_vars ?(locals=[||]) pos_table basic_ast =
let (extension, neg_table) =
P_graph.build_extension ~locals pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
P_graph.build_extension ?pat_vars ~locals pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
let filters = Pid_map.fold (fun id node acc -> Filter (id, P_node.get_fs node) :: acc) extension.P_graph.old_map [] in
{
graph = extension.P_graph.ext_map;
......@@ -305,21 +305,22 @@ module Rule = struct
let (pat_vars, cmd_vars) = parse_vars rule_ast.Ast.rule_loc vars in
let nb_pv = List.length pat_vars in
let nb_cv = List.length cmd_vars in
let param = List.fold_left
let local_param = match rule_ast.Ast.lex_par with
| None -> None
| Some lines -> Some (Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines) in
let full_param = List.fold_left
(fun acc file ->
Lex_par.append
(Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
acc
)
(match rule_ast.Ast.lp with
| None -> Lex_par.empty
| Some lines -> Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines
)
files in
(Some param, pat_vars, cmd_vars) in
match acc with
| None -> Some (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
| Some lp -> Some (Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file) lp)
) local_param files in
(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 ~locals pos_table basic_ast) rule_ast.Ast.neg_basics in
let negs = List.map (fun basic_ast -> build_neg_basic ~pat_vars ~locals pos_table basic_ast) rule_ast.Ast.neg_basics in
{
name = rule_ast.Ast.rule_id;
pattern = (pos, negs);
......@@ -433,7 +434,7 @@ module Rule = struct
}
(* ---------------------------------------------------------------------- *)
let fullfill graph matching cst =
let apply_cst graph matching cst =
let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
let get_string_feat pid = function
| "position" -> Some (sprintf "%g" (G_node.get_position (get_node pid)))
......@@ -445,45 +446,61 @@ module Rule = struct
match cst with
| Cst_out (pid,edge) ->
let gid = Pid_map.find pid matching.n_match in
G_graph.edge_out graph gid edge
if G_graph.edge_out graph gid edge
then matching
else raise Fail
| Cst_in (pid,edge) ->
let gid = Pid_map.find pid matching.n_match in
G_graph.node_exists
if G_graph.node_exists
(fun node ->
List.exists (fun e -> P_edge.compatible edge e) (Massoc_gid.assoc gid (G_node.get_next node))
) graph
then matching
else raise Fail
| Filter (pid, fs) ->
let gid = Pid_map.find pid matching.n_match in
let gnode = G_graph.find gid graph in
P_fs.filter fs (G_node.get_fs gnode)
begin
try
let gid = Pid_map.find pid matching.n_match in
let gnode = G_graph.find gid graph in
let new_param = P_fs.match_ ?param:matching.m_param fs (G_node.get_fs gnode) in
{matching with m_param = new_param }
with P_fs.Fail -> raise Fail
end
| Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
begin
match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
| Some fv1, Some fv2 when fv1 = fv2 -> true
| _ -> false
| Some fv1, Some fv2 when fv1 = fv2 -> matching
| _ -> raise Fail
end
| Feature_diseq (pid1, feat_name1, pid2, feat_name2) ->
begin
match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
| Some fv1, Some fv2 when fv1 <> fv2 -> true
| _ -> false
| Some fv1, Some fv2 when fv1 <> fv2 -> matching
| _ -> raise Fail
end
| Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
| (Ast.Lt, Some fv1, Some fv2) when fv1 < fv2 -> true
| (Ast.Gt, Some fv1, Some fv2) when fv1 > fv2 -> true
| (Ast.Le, Some fv1, Some fv2) when fv1 <= fv2 -> true
| (Ast.Ge, Some fv1, Some fv2) when fv1 >= fv2 -> true
| _ -> false
| (Ast.Lt, Some fv1, Some fv2) when fv1 < fv2 -> matching
| (Ast.Gt, Some fv1, Some fv2) when fv1 > fv2 -> matching
| (Ast.Le, Some fv1, Some fv2) when fv1 <= fv2 -> matching
| (Ast.Ge, Some fv1, Some fv2) when fv1 >= fv2 -> matching
| _ -> raise Fail
(* ---------------------------------------------------------------------- *)
(* returns all extension of the partial input matching *)
let rec extend_matching (positive,neg) (graph:G_graph.t) (partial:partial) =
match (partial.unmatched_edges, partial.unmatched_nodes) with
| [], [] ->
if List.for_all (fun const -> fullfill graph partial.sub const) partial.check