[multiple changes]

2010-06-17  Thomas Quinot  <quinot@adacore.com>

	* put_scos.adb: Do not generate a blank line in SCOs when omitting the
	CP line for a disabled pragma.

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.

From-SVN: r160875

5 files changed, 129 insertions, 62 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a624312..46a5096 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,15 @@
+2010-06-17  Thomas Quinot  <quinot@adacore.com>
+
+	* put_scos.adb: Do not generate a blank line in SCOs when omitting the
+	CP line for a disabled pragma.
+
+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.
+
 2010-06-16  Arnaud Charlet  <charlet@adacore.com>
 
 	* get_scos.adb, par_sco.adb, par_sco.ads, put_scos.adb, scos.adb,
diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb
index 1120d5b..57bfe51 100644
--- a/gcc/ada/prj-proc.adb
+++ b/gcc/ada/prj-proc.adb
@@ -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 ???
diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb
index 0bae53c..adfedce 100644
--- a/gcc/ada/prj.adb
+++ b/gcc/ada/prj.adb
@@ -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;
 
    ------------
diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads
index 353138d..7571ad2 100644
--- a/gcc/ada/prj.ads
+++ b/gcc/ada/prj.ads
@@ -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;
diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb
index 53962b2..db608af 100644
--- a/gcc/ada/put_scos.adb
+++ b/gcc/ada/put_scos.adb
@@ -134,6 +134,8 @@ begin
                         end if;
                      end loop;
 
+                     Write_Info_Terminate;
+
                   --  Statement continuations should not occur since they
                   --  are supposed to have been handled in the loop above.
 
@@ -197,13 +199,13 @@ begin
                               Start := Start + 1;
                            end;
                         end loop;
+
+                        Write_Info_Terminate;
                      end if;
 
                   when others =>
                      raise Program_Error;
                end case;
-
-               Write_Info_Terminate;
             end Output_SCO_Line;
 
             Start := Start + 1;