2011-08-04 Yannick Moy <moy@adacore.com>

	* sem_prag.adb (Check_Arg_Is_String_Literal): remove useless procedure
	(Analyze_Pragma): allow static string expression for name of Test_Case,
	instead of simply string literals.
	* sem_util.adb (Get_Name_From_Test_Case_Pragma): adapt to static string
	expressions.

2011-08-04  Vincent Celier  <celier@adacore.com>

	* makeutl.adb (Complete_Mains.Find_File_Add_Extension): Use canonical
	case suffixes to find truncated main sources.

2011-08-04  Tristan Gingold  <gingold@adacore.com>

	* impunit.adb (Non_Imp_File_Names_95): Add g-tastus.
	s-stusta.adb (Compute_All_Task): Use Put_Line instead of Put.
	(Compute_Current_Task): Ditto.

2011-08-04  Tristan Gingold  <gingold@adacore.com>

	* gnat_ugn.texi: Mention GNAT.Task_Stack_Usage.

2011-08-04  Yannick Moy  <moy@adacore.com>

	* lib-xref-alfa.adb (Is_Global_Constant): new function that detects
	library-level constant.
	(Add_ALFA_Xrefs): ignore global constants in ALFA xref.
	* sem_res.adb (Resolve_Actuals): do not add cross-reference to Formal
	used as selector of parameter association, in ALFA mode.



git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@177389 138bc75d-0d04-0410-961f-82ee72b054a4

9 files changed, 89 insertions, 45 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5089441c14e..01ac7c31ccb 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,34 @@
+2011-08-04  Yannick Moy  <moy@adacore.com>
+
+	* sem_prag.adb (Check_Arg_Is_String_Literal): remove useless procedure
+	(Analyze_Pragma): allow static string expression for name of Test_Case,
+	instead of simply string literals.
+	* sem_util.adb (Get_Name_From_Test_Case_Pragma): adapt to static string
+	expressions.
+
+2011-08-04  Vincent Celier  <celier@adacore.com>
+
+	* makeutl.adb (Complete_Mains.Find_File_Add_Extension): Use canonical
+	case suffixes to find truncated main sources.
+
+2011-08-04  Tristan Gingold  <gingold@adacore.com>
+
+	* impunit.adb (Non_Imp_File_Names_95): Add g-tastus.
+	s-stusta.adb (Compute_All_Task): Use Put_Line instead of Put.
+	(Compute_Current_Task): Ditto.
+
+2011-08-04  Tristan Gingold  <gingold@adacore.com>
+
+	* gnat_ugn.texi: Mention GNAT.Task_Stack_Usage.
+
+2011-08-04  Yannick Moy  <moy@adacore.com>
+
+	* lib-xref-alfa.adb (Is_Global_Constant): new function that detects
+	library-level constant.
+	(Add_ALFA_Xrefs): ignore global constants in ALFA xref.
+	* sem_res.adb (Resolve_Actuals): do not add cross-reference to Formal
+	used as selector of parameter association, in ALFA mode.
+
 2011-08-04  Robert Dewar  <dewar@adacore.com>
 
 	* exp_ch5.adb, exp_ch7.adb, exp_util.adb, bindgen.adb, sem_prag.adb,
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index ee2c381314e..d45a6fc3aa3 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -17285,6 +17285,9 @@ much has actually been used.
 The environment task stack, e.g., the stack that contains the main unit, is
 only processed when the environment variable GNAT_STACK_LIMIT is set.
 
+@noident
+The package @code{GNAT.Task_Stack_Usage} provides facilities to get
+stack usage reports at run-time. See its body for the details.
 
 @c *********************************
 @c *            GNATCHECK          *
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index 65e18428cd8..e58b345d72a 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -295,6 +295,7 @@ package body Impunit is
      "g-ssvety",    -- GNAT.SSE.Vector_Types
      "g-table ",    -- GNAT.Table
      "g-tasloc",    -- GNAT.Task_Lock
+     "g-tastus",    -- GNAT.Task_Stack_Usage
      "g-thread",    -- GNAT.Threads
      "g-timsta",    -- GNAT.Time_Stamp
      "g-traceb",    -- GNAT.Traceback
diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb
index 77da460df3f..0e0a4ff2973 100644
--- a/gcc/ada/lib-xref-alfa.adb
+++ b/gcc/ada/lib-xref-alfa.adb
@@ -524,6 +524,10 @@ package body ALFA is
          function Is_ALFA_Scope (E : Entity_Id) return Boolean;
          --  Return whether the entity or reference scope is adequate
 
+         function Is_Global_Constant (E : Entity_Id) return Boolean;
+         --  Return True if E is a global constant for which we should ignore
+         --  reads in ALFA.
+
          -------------------
          -- Is_ALFA_Scope --
          -------------------
@@ -536,6 +540,16 @@ package body ALFA is
               and then Get_Scope_Num (E) /= No_Scope;
          end Is_ALFA_Scope;
 
+         ------------------------
+         -- Is_Global_Constant --
+         ------------------------
+
+         function Is_Global_Constant (E : Entity_Id) return Boolean is
+         begin
+            return Ekind (E) in E_Constant
+              and then Ekind_In (Scope (E), E_Package, E_Package_Body);
+         end Is_Global_Constant;
+
          --  Start of processing for Eliminate_Before_Sort
       begin
 
@@ -547,6 +561,7 @@ package body ALFA is
               and then ALFA_References (Xrefs.Table (Rnums (J)).Typ)
               and then Is_ALFA_Scope (Xrefs.Table (Rnums (J)).Ent_Scope)
               and then Is_ALFA_Scope (Xrefs.Table (Rnums (J)).Ref_Scope)
+              and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Ent)
             then
                Nrefs         := Nrefs + 1;
                Rnums (Nrefs) := Rnums (J);
diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb
index 0be182e7413..f091690eb1f 100644
--- a/gcc/ada/makeutl.adb
+++ b/gcc/ada/makeutl.adb
@@ -1368,9 +1368,16 @@ package body Makeutl is
                      Suffix :=
                        Source.Language.Config.Naming_Data.Body_Suffix;
 
-                     exit when Suffix /= No_File and then
-                       Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
-                       Get_Name_String (Suffix);
+                     if Suffix /= No_File then
+                        declare
+                           Suffix_Str : String := Get_Name_String (Suffix);
+                        begin
+                           Canonical_Case_File_Name (Suffix_Str);
+                           exit when
+                             Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
+                             Suffix_Str;
+                        end;
+                     end if;
                   end if;
 
                elsif Source.Kind = Spec then
@@ -1385,12 +1392,18 @@ package body Makeutl is
                      Suffix :=
                        Source.Language.Config.Naming_Data.Spec_Suffix;
 
-                     if Suffix /= No_File
-                       and then
-                         Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
-                         Get_Name_String (Suffix)
-                     then
-                        Spec_Source := Source;
+                     if Suffix /= No_File then
+                        declare
+                           Suffix_Str : String := Get_Name_String (Suffix);
+                        begin
+                           Canonical_Case_File_Name (Suffix_Str);
+
+                           if Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
+                             Suffix_Str
+                           then
+                              Spec_Source := Source;
+                           end if;
+                        end;
                      end if;
                   end if;
                end if;
diff --git a/gcc/ada/s-stusta.adb b/gcc/ada/s-stusta.adb
index 8961759ce10..f899266218e 100644
--- a/gcc/ada/s-stusta.adb
+++ b/gcc/ada/s-stusta.adb
@@ -92,7 +92,7 @@ package body System.Stack_Usage.Tasking is
       use type System.Tasking.Task_Id;
    begin
       if not System.Stack_Usage.Is_Enabled then
-         Put ("Stack Usage not enabled: bind with -uNNN switch");
+         Put_Line ("Stack Usage not enabled: bind with -uNNN switch");
       else
 
          --  Loop over all tasks
@@ -118,7 +118,7 @@ package body System.Stack_Usage.Tasking is
    procedure Compute_Current_Task is
    begin
       if not System.Stack_Usage.Is_Enabled then
-         Put ("Stack Usage not enabled: bind with -uNNN switch");
+         Put_Line ("Stack Usage not enabled: bind with -uNNN switch");
       else
 
          --  The current task
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index a0b56a98c98..8c95ada1cc4 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -335,10 +335,6 @@ package body Sem_Prag is
       --  Check the specified argument Arg to make sure that it is an integer
       --  literal. If not give error and raise Pragma_Exit.
 
-      procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
-      --  Check the specified argument Arg to make sure that it is a string
-      --  literal. If not give error and raise Pragma_Exit.
-
       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
       --  Check the specified argument Arg to make sure that it has the proper
       --  syntactic form for a local name and meets the semantic requirements
@@ -426,9 +422,9 @@ package body Sem_Prag is
       --  Checks that the given argument has an identifier, and if so, requires
       --  it to match one of the given identifier names. If there is no
       --  identifier, or a non-matching identifier, then an error message is
-      --  given and Pragma_Exit is raised. ??? why is this needed, why isnt
-      --  Check_Arg_Is_One_Of good enough. At the very least explain this
-      --  odd apparent redundancy
+      --  given and Pragma_Exit is raised. This checks the optional identifier
+      --  of a pragma argument, not the argument itself like
+      --  Check_Arg_Is_One_Of does.
 
       procedure Check_In_Main_Program;
       --  Common checks for pragmas that appear within a main program
@@ -901,19 +897,6 @@ package body Sem_Prag is
          end if;
       end Check_Arg_Is_Integer_Literal;
 
-      ---------------------------------
-      -- Check_Arg_Is_String_Literal --
-      ---------------------------------
-
-      procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
-         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
-      begin
-         if Nkind (Argx) /= N_String_Literal then
-            Error_Pragma_Arg
-              ("argument for pragma% must be string literal", Argx);
-         end if;
-      end Check_Arg_Is_String_Literal;
-
       -------------------------------------------
       -- Check_Arg_Is_Library_Level_Local_Name --
       -------------------------------------------
@@ -13264,17 +13247,12 @@ package body Sem_Prag is
          -- Test_Case --
          ---------------
 
-         --  pragma Test_Case ([Name     =>] String_EXPRESSION
+         --  pragma Test_Case ([Name     =>] static_string_EXPRESSION
          --                   ,[Mode     =>] (Normal | Robustness)
          --                  [, Requires =>  Boolean_EXPRESSION]
          --                  [, Ensures  =>  Boolean_EXPRESSION]);
 
-         --  ??? Why is Name not static_string_EXPRESSION??? Seems very
-         --  weird to require it to be a string literal, and if we DO want
-         --  that restriction the grammar should make this clear.
-
          when Pragma_Test_Case => Test_Case : declare
-
          begin
             GNAT_Pragma;
             Check_At_Least_N_Arguments (3);
@@ -13283,7 +13261,7 @@ package body Sem_Prag is
               ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
 
             Check_Optional_Identifier (Arg1, Name_Name);
-            Check_Arg_Is_String_Literal (Arg1);
+            Check_Arg_Is_Static_Expression (Arg1, Standard_String);
             Check_Optional_Identifier (Arg2, Name_Mode);
             Check_Arg_Is_One_Of (Arg2, Name_Normal, Name_Robustness);
 
@@ -13291,9 +13269,6 @@ package body Sem_Prag is
                Check_Identifier (Arg3, Name_Requires);
                Check_Identifier (Arg4, Name_Ensures);
             else
-               --  ??? why not Check_Arg_Is_One_Of, very odd!!! At the very
-               --  least needs an explanation!
-
                Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
             end if;
 
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index c79672f8853..f383809bf3d 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3971,9 +3971,14 @@ package body Sem_Res is
             Eval_Actual (A);
 
             --  If it is a named association, treat the selector_name as a
-            --  proper identifier, and mark the corresponding entity.
+            --  proper identifier, and mark the corresponding entity. Ignore
+            --  this reference in ALFA mode, as it refers to an entity not in
+            --  scope at the point of reference, so the reference should be
+            --  ignored for computing effects of subprograms.
 
-            if Nkind (Parent (A)) = N_Parameter_Association then
+            if Nkind (Parent (A)) = N_Parameter_Association
+              and then not ALFA_Mode
+            then
                Set_Entity (Selector_Name (Parent (A)), F);
                Generate_Reference (F, Selector_Name (Parent (A)));
                Set_Etype (Selector_Name (Parent (A)), F_Typ);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b7e3f21ff76..0c36811ec5b 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -4336,9 +4336,10 @@ package body Sem_Util is
    ------------------------------------
 
    function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id is
+      Arg : constant Node_Id :=
+              Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
    begin
-      return
-        Strval (Get_Pragma_Arg (First (Pragma_Argument_Associations (N))));
+      return Strval (Expr_Value_S (Arg));
    end Get_Name_From_Test_Case_Pragma;
 
    -------------------