Commit 16756e09 authored by bguillaum's avatar bguillaum

add more checking for consistency between rules and feature domain at GRS loading time

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8450 7838e531-6607-4d57-9587-6c381814729c
parent 10b1ea3d
......@@ -163,6 +163,7 @@ module Command = struct
if feat_name = "position"
then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
check_act_id loc act_id kai;
Domain.check_feature_name ~loc feat_name;
((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
| (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
......@@ -173,16 +174,23 @@ module Command = struct
| Ast.Qfn_item ci when Ast.is_simple ci -> String (Ast.complex_id_to_string ci)
| Ast.Qfn_item ci ->
let (act_id,feature_name) = Ast.act_qfn_of_ci ci in
check_act_id loc act_id kai; Feat (pid_of_act_id loc act_id, feature_name)
check_act_id loc act_id kai;
Domain.check_feature_name ~loc feature_name;
Feat (pid_of_act_id loc act_id, feature_name)
| Ast.String_item s -> String s
| Ast.Param_item var ->
match param with
| None -> Error.build "Unknown command variable '%s'" var
| None -> Error.build ~loc "Unknown command variable '%s'" var
| Some (par,cmd) ->
match (List_.pos var par, List_.pos var cmd) with
| (_,Some index) -> Param_out index
| (Some index,_) -> Param_in index
| _ -> Error.build "Unknown command variable '%s'" var
| _ -> Error.build ~loc "Unknown command variable '%s'" var
) ast_items in
(* check for consistency *)
(match items with
| [String s] -> Domain.check_feature ~loc feat_name s
| _ when Domain.is_open feat_name -> ()
| _ -> Error.build ~loc "Only open features can be modified with the concat operator '+' but \"%s\" is not declared as an open feature" feat_name);
((UPDATE_FEAT (pid_of_act_id loc act_id, feat_name, items), loc), (kai, kei))
end (* module Command *)
......@@ -34,8 +34,10 @@ module P_graph = struct
type t = P_node.t Pid_map.t
let empty = Pid_map.empty
let find = Pid_map.find
(* -------------------------------------------------------------------------------- *)
let map_add_edge map id_src label id_tar =
let node_src =
(* Not found can be raised when adding an edge from pos to neg *)
......@@ -44,10 +46,6 @@ module P_graph = struct
| None -> None
| Some new_node -> Some (Pid_map.add id_src new_node map)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Build functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* -------------------------------------------------------------------------------- *)
let build_filter table (ast_node, loc) =
let pid = Id.build ~loc ast_node.Ast.node_id table in
......@@ -155,6 +153,7 @@ module P_graph = struct
) ext_map_without_edges full_edge_list in
({ext_map = ext_map_with_all_edges; old_map = old_map_without_edges}, new_table)
(* -------------------------------------------------------------------------------- *)
(* [tree_and_roots t] returns:
- a boolean which is true iff the each node has at most one in-edge
- the list of "roots" (i.e. nodes without in-edge *)
......@@ -184,6 +183,7 @@ module P_graph = struct
(!tree_prop, roots)
(* -------------------------------------------------------------------------------- *)
let roots graph = snd (tree_and_roots graph)
end (* module P_graph *)
......@@ -195,33 +195,17 @@ module G_deco = struct
}
let empty = {nodes=[]; edges=[]}
let dump t =
printf "|nodes|=%d\n" (List.length t.nodes);
List.iter
(fun (gid, (pid,list)) ->
printf " - %s %s %s\n"
(Gid.to_string gid)
pid
(String.concat "/" list)
) t.nodes;
printf "|edges|=%d\n" (List.length t.edges);
List.iter
(fun (src, edge, tar) ->
printf " - %s --[%s]--> %s\n"
(Gid.to_string src)
(G_edge.to_string edge)
(Gid.to_string tar)
) t.edges
end (* module G_deco *)
(* ================================================================================ *)
module G_graph = struct
type t = {
meta: (string * string) list;
map: G_node.t Gid_map.t; (* node description *)
meta: (string * string) list; (* meta-informations *)
map: G_node.t Gid_map.t; (* node description *)
}
let empty = {meta=[]; map=Gid_map.empty}
(* ---------------------------------------------------------------------- *)
let rename mapping graph =
{graph with map =
......@@ -246,7 +230,6 @@ module G_graph = struct
) t.map (0, []) in
rename mapping t
let empty = {meta=[]; map=Gid_map.empty}
let find node_id graph = Gid_map.find node_id graph.map
......@@ -296,6 +279,7 @@ module G_graph = struct
| None -> None
| Some new_node -> Some (Gid_map.add id_src new_node map)
(* -------------------------------------------------------------------------------- *)
let add_edge graph id_src label id_tar =
match map_add_edge graph.map id_src label id_tar with
| Some new_map -> Some {graph with map = new_map }
......@@ -707,10 +691,6 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
let to_dot ?main_feat ?(deco=G_deco.empty) graph =
printf "<==== [G_graph.to_dot] ====>\n";
G_deco.dump deco;
let buff = Buffer.create 32 in
bprintf buff "digraph G {\n";
......@@ -745,7 +725,6 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
let to_raw graph =
let nodes = Gid_map.fold (fun id elt acc -> (id,elt)::acc) graph.map [] in
let snodes = List.sort (fun (_,n1) (_,n2) -> G_node.position_comp n1 n2) nodes in
let raw_nodes = List.map (fun (gid,node) -> (gid, G_fs.to_raw (G_node.get_fs node))) snodes in
......
......@@ -21,7 +21,7 @@ open Grew_command
module P_deco: sig
type t =
{ nodes: Pid.t list;
edges: (Pid.t * P_edge.t * Pid.t) list;
edges: (Pid.t * P_edge.t * Pid.t) list;
}
val empty:t
......@@ -31,12 +31,10 @@ end (* module P_deco *)
module G_deco: sig
type t =
{ nodes: (Gid.t * (string * string list)) list;
edges: (Gid.t * G_edge.t * Gid.t) list;
edges: (Gid.t * G_edge.t * Gid.t) list;
}
val empty:t
val dump: t -> unit
end (* module G_deco *)
(* ================================================================================ *)
......@@ -54,23 +52,19 @@ module P_graph: sig
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Build functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
val build:
?pat_vars: string list ->
?locals: Label.decl array ->
Ast.node list ->
Ast.edge list ->
(t * Id.table)
(t * Id.table)
val build_extension:
?locals: Label.decl array ->
Id.table ->
Ast.node list ->
Ast.edge list ->
(extension * Id.table)
(extension * Id.table)
end (* module P_graph *)
(* ================================================================================ *)
......
......@@ -217,6 +217,10 @@ module Domain = struct
type t = feature_spec list
let (current: t option ref) = ref None
let reset () = current := None
let is_defined feature_name domain =
List.exists (function
| Closed (fn,_) when fn = feature_name -> true
......@@ -225,6 +229,17 @@ module Domain = struct
| _ -> false
) domain
let check_feature_name ?loc name =
match !current with
| None -> ()
| Some dom when is_defined name dom -> ()
| _ -> Error.build ?loc "The feature name \"%s\" in not defined in the domain" name
let is_open name =
match !current with
| None -> true
| Some dom -> List.exists (function Open n when n=name -> true | _ -> false) dom
let rec normalize_domain = function
| [] -> [Num "position"]
| (Num "position") :: tail -> Log.warning "[Domain] declaration of the feature name \"position\" in useless"; normalize_domain tail
......@@ -235,10 +250,6 @@ module Domain = struct
Error.build "[Domain] The feature named \"%s\" is defined several times" fn
| x :: tail -> x :: (normalize_domain tail)
let current = ref None
let reset () = current := None
let init domain =
current := Some (normalize_domain domain)
......@@ -271,6 +282,9 @@ module Domain = struct
| [x] -> x
| _ -> Error.bug ?loc "[Domain.build_one]"
let check_feature ?loc name value =
ignore (build ?loc name [value])
let feature_names () =
match !current with
| None -> None
......
......@@ -106,6 +106,16 @@ module Domain: sig
val build_one: ?loc:Loc.t -> feature_name -> feature_atom -> value
val feature_names: unit -> string list option
(** [check_feature_name ~loc feature_name] fails iff a domain is set and [feature_name] is not defined in the current domain. *)
val check_feature_name: ?loc:Loc.t -> feature_name -> unit
(** [check_feature ~loc feature_name feature_value] fails iff a domain is set and [feature_name,feature_value] is not defined in the current domain. *)
val check_feature: ?loc:Loc.t -> feature_name -> feature_atom -> unit
(** [is_open feature_name] returns [true] iff no domain is set or if [feature_name] is defined to be open in the current domain. *)
val is_open: feature_name -> bool
end (* module Domain *)
(* ================================================================================ *)
......
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