Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

Commit 10955eaf authored by Bruno Guillaume's avatar Bruno Guillaume
Browse files

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

parent 9833fe6c
......@@ -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