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

src/grew_command.ml

@@ -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 *)

src/grew_graph.ml

@@ -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

src/grew_graph.mli

@@ -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 *)
 
 (* ================================================================================ *)

src/grew_types.ml

@@ -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

src/grew_types.mli

@@ -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 *)
 
 (* ================================================================================ *)