Patchwork [Ada] behavior of invalid typed variable in project files

login
register
mail settings
Submitter Arnaud Charlet
Date June 17, 2010, 7:11 a.m.
Message ID <20100617071158.GA24675@adacore.com>
Download mbox | patch
Permalink /patch/55976/
State New
Headers show

Comments

Arnaud Charlet - June 17, 2010, 7:11 a.m.
When parsing a project file, an invalid value given to a typed
variable, in particular when this value comes from the environment,
is no longer systematically fatal. In several contexts (IDEs...)
we still want to manipulate the project. A new flag was introduced
to control this behavior.

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-17  Emmanuel Briot  <briot@adacore.com>

	* prj-proc.adb, prj.adb, prj.ads (Check_Or_Set_Typed_Variable): New
	subprogram.
	(Process_Declarative_Item): An invalid value in an typed variable
	declaration is no longer always fatal.

Patch

Index: prj-proc.adb
===================================================================
--- prj-proc.adb	(revision 160834)
+++ prj-proc.adb	(working copy)
@@ -1255,9 +1255,101 @@  package body Prj.Proc is
       Pkg                    : Package_Id;
       Item                   : Project_Node_Id)
    is
+      procedure Check_Or_Set_Typed_Variable
+        (Value       : in out Variable_Value;
+         Declaration : Project_Node_Id);
+      --  Check whether Value is valid for this typed variable declaration. If
+      --  it is an error, the behavior depends on the flags: either an error is
+      --  reported, or a warning, or nothing. In the last two cases, the value
+      --  of the variable is set to a valid value, replacing Value.
+
+      ---------------------------------
+      -- Check_Or_Set_Typed_Variable --
+      ---------------------------------
+
+      procedure Check_Or_Set_Typed_Variable
+        (Value       : in out Variable_Value;
+         Declaration : Project_Node_Id)
+      is
+         Loc : constant Source_Ptr :=
+                 Location_Of (Declaration, From_Project_Node_Tree);
+
+         Reset_Value    : Boolean := False;
+         Current_String : Project_Node_Id;
+
+      begin
+         --  Report an error for an empty string
+
+         if Value.Value = Empty_String then
+            Error_Msg_Name_1 := Name_Of (Declaration, From_Project_Node_Tree);
+
+            case Flags.Allow_Invalid_External is
+               when Error =>
+                  Error_Msg (Flags, "no value defined for %%", Loc, Project);
+               when Warning =>
+                  Reset_Value := True;
+                  Error_Msg (Flags, "?no value defined for %%", Loc, Project);
+               when Silent =>
+                  Reset_Value := True;
+            end case;
+
+         else
+            --  Loop through all the valid strings for the
+            --  string type and compare to the string value.
+
+            Current_String :=
+              First_Literal_String
+                (String_Type_Of (Declaration, From_Project_Node_Tree),
+                 From_Project_Node_Tree);
+            while Present (Current_String)
+              and then String_Value_Of
+                (Current_String, From_Project_Node_Tree) /= Value.Value
+            loop
+               Current_String :=
+                 Next_Literal_String (Current_String, From_Project_Node_Tree);
+            end loop;
+
+            --  Report error if string value is not one for the string type
+
+            if No (Current_String) then
+               Error_Msg_Name_1 := Value.Value;
+               Error_Msg_Name_2 :=
+                 Name_Of (Declaration, From_Project_Node_Tree);
+
+               case Flags.Allow_Invalid_External is
+                  when Error =>
+                     Error_Msg
+                       (Flags, "value %% is illegal for typed string %%",
+                        Loc, Project);
+                  when Warning =>
+                     Error_Msg
+                       (Flags, "?value %% is illegal for typed string %%",
+                        Loc, Project);
+                     Reset_Value := True;
+                  when Silent =>
+                     Reset_Value := True;
+               end case;
+            end if;
+         end if;
+
+         if Reset_Value then
+            Current_String :=
+              First_Literal_String
+                (String_Type_Of (Declaration, From_Project_Node_Tree),
+                 From_Project_Node_Tree);
+
+            Value.Value := String_Value_Of
+              (Current_String, From_Project_Node_Tree);
+         end if;
+      end Check_Or_Set_Typed_Variable;
+
+      --  Local variables
+
       Current_Declarative_Item : Project_Node_Id;
       Current_Item             : Project_Node_Id;
 
+   --  Start of processing for Process_Declarative_Items
+
    begin
       --  Loop through declarative items
 
@@ -1677,7 +1769,7 @@  package body Prj.Proc is
 
                else
                   declare
-                     New_Value : constant Variable_Value :=
+                     New_Value : Variable_Value :=
                        Expression
                          (Project                => Project,
                           In_Tree                => In_Tree,
@@ -1713,59 +1805,9 @@  package body Prj.Proc is
                      if Kind_Of (Current_Item, From_Project_Node_Tree) =
                           N_Typed_Variable_Declaration
                      then
-                        --  Report an error for an empty string
-
-                        if New_Value.Value = Empty_String then
-                           Error_Msg_Name_1 :=
-                             Name_Of (Current_Item, From_Project_Node_Tree);
-                           Error_Msg
-                             (Flags,
-                              "no value defined for %%",
-                              Location_Of
-                                (Current_Item, From_Project_Node_Tree),
-                              Project);
-
-                        else
-                           declare
-                              Current_String : Project_Node_Id;
-
-                           begin
-                              --  Loop through all the valid strings for the
-                              --  string type and compare to the string value.
-
-                              Current_String :=
-                                First_Literal_String
-                                  (String_Type_Of (Current_Item,
-                                                   From_Project_Node_Tree),
-                                                   From_Project_Node_Tree);
-                              while Present (Current_String)
-                                and then
-                                  String_Value_Of
-                                    (Current_String, From_Project_Node_Tree) /=
-                                                               New_Value.Value
-                              loop
-                                 Current_String :=
-                                   Next_Literal_String
-                                     (Current_String, From_Project_Node_Tree);
-                              end loop;
-
-                              --  Report an error if the string value is not
-                              --  one for the string type.
-
-                              if No (Current_String) then
-                                 Error_Msg_Name_1 := New_Value.Value;
-                                 Error_Msg_Name_2 :=
-                                   Name_Of
-                                     (Current_Item, From_Project_Node_Tree);
-                                 Error_Msg
-                                   (Flags,
-                                    "value %% is illegal for typed string %%",
-                                    Location_Of
-                                      (Current_Item, From_Project_Node_Tree),
-                                    Project);
-                              end if;
-                           end;
-                        end if;
+                        Check_Or_Set_Typed_Variable
+                          (Value       => New_Value,
+                           Declaration => Current_Item);
                      end if;
 
                      --  Comment here ???
Index: prj.adb
===================================================================
--- prj.adb	(revision 160834)
+++ prj.adb	(working copy)
@@ -1230,7 +1230,8 @@  package body Prj is
       Allow_Duplicate_Basenames  : Boolean := True;
       Compiler_Driver_Mandatory  : Boolean := False;
       Error_On_Unknown_Language  : Boolean := True;
-      Require_Obj_Dirs           : Error_Warning := Error)
+      Require_Obj_Dirs           : Error_Warning := Error;
+      Allow_Invalid_External     : Error_Warning := Error)
       return Processing_Flags
    is
    begin
@@ -1241,7 +1242,8 @@  package body Prj is
          Allow_Duplicate_Basenames  => Allow_Duplicate_Basenames,
          Error_On_Unknown_Language  => Error_On_Unknown_Language,
          Compiler_Driver_Mandatory  => Compiler_Driver_Mandatory,
-         Require_Obj_Dirs           => Require_Obj_Dirs);
+         Require_Obj_Dirs           => Require_Obj_Dirs,
+         Allow_Invalid_External     => Allow_Invalid_External);
    end Create_Flags;
 
    ------------
Index: prj.ads
===================================================================
--- prj.ads	(revision 160834)
+++ prj.ads	(working copy)
@@ -1452,7 +1452,8 @@  package Prj is
       Allow_Duplicate_Basenames  : Boolean := True;
       Compiler_Driver_Mandatory  : Boolean := False;
       Error_On_Unknown_Language  : Boolean := True;
-      Require_Obj_Dirs           : Error_Warning := Error)
+      Require_Obj_Dirs           : Error_Warning := Error;
+      Allow_Invalid_External     : Error_Warning := Error)
       return Processing_Flags;
    --  Function used to create Processing_Flags structure
    --
@@ -1481,6 +1482,10 @@  package Prj is
    --  If Require_Obj_Dirs is true, then all object directories must exist
    --  (possibly after they have been created automatically if the appropriate
    --  switches were specified), or an error is raised.
+   --
+   --  If Allow_Invalid_External is Silent, then no error is reported when an
+   --  invalid value is used for an external variable (and it doesn't match its
+   --  type). Instead, the first possible value is used.
 
    Gprbuild_Flags : constant Processing_Flags;
    Gprclean_Flags : constant Processing_Flags;
@@ -1589,6 +1594,7 @@  private
       Compiler_Driver_Mandatory  : Boolean;
       Error_On_Unknown_Language  : Boolean;
       Require_Obj_Dirs           : Error_Warning;
+      Allow_Invalid_External     : Error_Warning;
    end record;
 
    Gprbuild_Flags : constant Processing_Flags :=
@@ -1598,7 +1604,8 @@  private
       Allow_Duplicate_Basenames  => False,
       Compiler_Driver_Mandatory  => True,
       Error_On_Unknown_Language  => True,
-      Require_Obj_Dirs           => Error);
+      Require_Obj_Dirs           => Error,
+      Allow_Invalid_External     => Error);
 
    Gprclean_Flags : constant Processing_Flags :=
      (Report_Error               => null,
@@ -1607,7 +1614,8 @@  private
       Allow_Duplicate_Basenames  => False,
       Compiler_Driver_Mandatory  => True,
       Error_On_Unknown_Language  => True,
-      Require_Obj_Dirs           => Warning);
+      Require_Obj_Dirs           => Warning,
+      Allow_Invalid_External     => Error);
 
    Gnatmake_Flags : constant Processing_Flags :=
      (Report_Error               => null,
@@ -1616,6 +1624,7 @@  private
       Allow_Duplicate_Basenames  => False,
       Compiler_Driver_Mandatory  => False,
       Error_On_Unknown_Language  => False,
-      Require_Obj_Dirs           => Error);
+      Require_Obj_Dirs           => Error,
+      Allow_Invalid_External     => Error);
 
 end Prj;