+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,
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 *
"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
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 --
-------------------
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
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);
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
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;
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
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
-- 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
-- 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
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 --
-------------------------------------------
-- 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);
((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);
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;
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);
------------------------------------
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;
-------------------
projects / gcc.git / commitdiff