Skip to content

R
riscv-gcc-1
Commit 8e983d80 by Arnaud Charlet
Options

[multiple changes] 

2012-10-01  Thomas Quinot  <quinot@adacore.com>

	* gnatcmd.adb, make.adb (Scan_Make_Arg, Inspect_Switches): Recognize
	and reject an invalid parameter passed to -vP.

2012-10-01  Yannick Moy  <moy@adacore.com>

	* sem_warn.adb (Check_Infinite_Loop_Warning/Test_Ref): Improve
	the detection of modifications to the loop variable by noting
	that, if the type of variable is elementary and the condition
	does not contain a function call, then the condition cannot be
	modified by side-effects from a procedure call.

2012-10-01  Robert Dewar  <dewar@adacore.com>

	* checks.adb: Add comments.

2012-10-01  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Expand_N_Object_Declaration): Improve condition catching
	never-ending recursion. The previous condition erroneously disabled
	silently the expansion of the class-wide interface object
	initialization in cases not involving the recursion.

From-SVN: r191892
parent 7246b890
Showing with 106 additions and 51 deletions
gcc/ada/ChangeLog
2012-10-01 Thomas Quinot <quinot@adacore.com>
* gnatcmd.adb, make.adb (Scan_Make_Arg, Inspect_Switches): Recognize
and reject an invalid parameter passed to -vP.
2012-10-01 Yannick Moy <moy@adacore.com>
* sem_warn.adb (Check_Infinite_Loop_Warning/Test_Ref): Improve
the detection of modifications to the loop variable by noting
that, if the type of variable is elementary and the condition
does not contain a function call, then the condition cannot be
modified by side-effects from a procedure call.
2012-10-01 Robert Dewar <dewar@adacore.com>
* checks.adb: Add comments.
2012-10-01 Javier Miranda <miranda@adacore.com>
* exp_ch3.adb (Expand_N_Object_Declaration): Improve condition catching
never-ending recursion. The previous condition erroneously disabled
silently the expansion of the class-wide interface object
initialization in cases not involving the recursion.
2012-10-01 Thomas Quinot <quinot@adacore.com>
* make.adb: Minor documentation fix: error messages are sent to
stderr, not stdout.
......
gcc/ada/checks.adb
......@@ -1791,6 +1791,8 @@ package body Checks is
-- Do not generate the checks in Ada 83, 95 or 05 mode because they
-- require an Ada 2012 construct.
-- Why??? these pragmas and attributes are available in all ada modes
if Ada_Version_Explicit < Ada_2012 then
return;
end if;
......@@ -1932,9 +1934,11 @@ package body Checks is
-- Extract the subprogram specification and declaration nodes
Subp_Spec := Parent (Subp);
if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then
Subp_Spec := Parent (Subp_Spec);
end if;
Subp_Decl := Parent (Subp_Spec);
-- Do not generate checks in Ada 83 or 95 because the pragmas involved
......@@ -1961,6 +1965,9 @@ package body Checks is
-- through the its contract and recover the pre and post conditions (if
-- available).
-- So what??? you can have multiple such pragmas, this is unnecessary
-- complexity being added for no purpose???
if Present (Contract (Subp)) then
declare
Nam : Name_Id;
......@@ -2080,6 +2087,9 @@ package body Checks is
-- Do not process subprograms where pre and post conditions do not make
-- sense.
-- More detail here of why these specific conditions are needed???
-- And remember to document them ???
if not Comes_From_Source (Subp)
or else Is_Imported (Subp)
or else Is_Intrinsic_Subprogram (Subp)
......@@ -2127,6 +2137,7 @@ package body Checks is
procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
S : Entity_Id;
begin
if Present (Predicate_Function (Typ)) then
......@@ -2134,17 +2145,12 @@ package body Checks is
-- subprograms, such as TSS functions.
S := Current_Scope;
while Present (S)
and then not Is_Subprogram (S)
loop
while Present (S) and then not Is_Subprogram (S) loop
S := Scope (S);
end loop;
if Present (S)
and then Get_TSS_Name (S) /= TSS_Null
then
if Present (S) and then Get_TSS_Name (S) /= TSS_Null then
return;
else
Insert_Action (N,
Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
......
gcc/ada/exp_ch3.adb
......@@ -4910,8 +4910,15 @@ package body Exp_Ch3 is
-- Expr's type, both types share the same dispatch table and there is
-- no need to displace the pointer.
elsif Comes_From_Source (N)
and then Is_Interface (Typ)
elsif Is_Interface (Typ)
-- Avoid never-ending recursion because if Equivalent_Type is set
-- then we've done it already and must not do it again!
and then not
(Nkind (Object_Definition (N)) = N_Identifier
and then
Present (Equivalent_Type (Entity (Object_Definition (N)))))
then
pragma Assert (Is_Class_Wide_Type (Typ));
......
gcc/ada/gnatcmd.adb
......@@ -1769,19 +1769,27 @@ begin
-- -vPx Specify verbosity while parsing project files
elsif Argv'Length = 4
and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
then
case Argv (Argv'Last) is
when '0' =>
Current_Verbosity := Prj.Default;
when '1' =>
Current_Verbosity := Prj.Medium;
when '2' =>
Current_Verbosity := Prj.High;
when others =>
Fail ("Invalid switch: " & Argv.all);
end case;
elsif Argv (Argv'First + 1 .. Argv'First + 2) = "vP" then
if Argv'Length = 4
and then Argv (Argv'Last) in '0' .. '2'
then
case Argv (Argv'Last) is
when '0' =>
Current_Verbosity := Prj.Default;
when '1' =>
Current_Verbosity := Prj.Medium;
when '2' =>
Current_Verbosity := Prj.High;
when others =>
-- Cannot happen
raise Program_Error;
end case;
else
Fail ("invalid verbosity level: "
& Argv (Argv'First + 3 .. Argv'Last));
end if;
Remove_Switch (Arg_Num);
......
gcc/ada/make.adb
......@@ -7825,11 +7825,12 @@ package body Make is
-- -vPx (verbosity of the parsing of the project files)
elsif Argv'Last = 4
and then Argv (2 .. 3) = "vP"
and then Argv (4) in '0' .. '2'
then
if And_Save then
elsif Argv (2 .. 3) = "vP" then
if Argv'Last /= 4 or else Argv (4) not in '0' .. '2' then
Make_Failed
("invalid verbosity level " & Argv (4 .. Argv'Last));
elsif And_Save then
case Argv (4) is
when '0' =>
Current_Verbosity := Prj.Default;
......
gcc/ada/sem_warn.adb
......@@ -472,32 +472,41 @@ package body Sem_Warn is
return Abandon;
end if;
-- If we appear in the context of a procedure call, then also
-- abandon, since there may be issues of non-visible side
-- effects going on in the call.
-- If the condition contains a function call, we consider it may
-- be modified by side-effects from a procedure call. Otherwise,
-- we consider the condition may not be modified, although that
-- might happen if Variable is itself a by-reference parameter,
-- and the procedure called modifies the global object referred to
-- by Variable, but we actually prefer to issue a warning in this
-- odd case. Note that the case where the procedure called has
-- visibility over Variable is treated in another case below.
if Function_Call_Found then
declare
P : Node_Id;
declare
P : Node_Id;
begin
P := N;
loop
P := Parent (P);
exit when P = Loop_Statement;
begin
P := N;
loop
P := Parent (P);
exit when P = Loop_Statement;
-- Abandon if at procedure call, or something strange is
-- going on (perhaps a node with no parent that should
-- have one but does not?) As always, for a warning we
-- prefer to just abandon the warning than get into the
-- business of complaining about the tree structure here!
if No (P) or else Nkind (P) = N_Procedure_Call_Statement then
return Abandon;
end if;
end loop;
end;
-- Abandon if at procedure call, or something strange is
-- going on (perhaps a node with no parent that should
-- have one but does not?) As always, for a warning we
-- prefer to just abandon the warning than get into the
-- business of complaining about the tree structure here!
if No (P)
or else Nkind (P) = N_Procedure_Call_Statement
then
return Abandon;
end if;
end loop;
end;
end if;
-- Reference to variable renaming variable in question
-- Reference to variable renaming variable in question
elsif Is_Entity_Name (N)
and then Present (Entity (N))
......@@ -509,7 +518,7 @@ package body Sem_Warn is
then
return Abandon;
-- Call to subprogram
-- Call to subprogram
elsif Nkind (N) in N_Subprogram_Call then
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment