From 1f9939b5d9f5722d18fc84139826b2d8845a68c2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 4 Aug 2011 15:54:52 +0200 Subject: [PATCH] [multiple changes] 2011-08-04 Yannick Moy * 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 * makeutl.adb (Complete_Mains.Find_File_Add_Extension): Use canonical case suffixes to find truncated main sources. 2011-08-04 Tristan Gingold * 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 * gnat_ugn.texi: Mention GNAT.Task_Stack_Usage. 2011-08-04 Yannick Moy * 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. From-SVN: r177389 --- gcc/ada/ChangeLog | 31 +++++++++++++++++++++++++++++++ gcc/ada/gnat_ugn.texi | 3 +++ gcc/ada/impunit.adb | 1 + gcc/ada/lib-xref-alfa.adb | 15 +++++++++++++++ gcc/ada/makeutl.adb | 31 ++++++++++++++++++++++--------- gcc/ada/s-stusta.adb | 4 ++-- gcc/ada/sem_prag.adb | 35 +++++------------------------------ gcc/ada/sem_res.adb | 9 +++++++-- gcc/ada/sem_util.adb | 5 +++-- 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 + + * 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 + + * makeutl.adb (Complete_Mains.Find_File_Add_Extension): Use canonical + case suffixes to find truncated main sources. + +2011-08-04 Tristan Gingold + + * 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 + + * gnat_ugn.texi: Mention GNAT.Task_Stack_Usage. + +2011-08-04 Yannick Moy + + * 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 * 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; ------------------- -- 2.30.2