OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2016-06-22  Hristian Kirtchev  <kirtchev@adacore.com>

	* lib-xref-spark_specific.adb, a-cuprqu.ads, sem_ch6.adb: Minor
	reformatting.

2016-06-22  Eric Botcazou  <ebotcazou@adacore.com>

	* sem_util.ads (Address_Value): Declare new function.
	* sem_util.adb (Address_Value): New function extracted
	unmodified from Apply_Address_Clause_Check, which returns the
	underlying value of the expression of an address clause.
	* checks.adb (Compile_Time_Bad_Alignment): Delete.
	(Apply_Address_Clause_Check): Call Address_Value on
	the expression.  Do not issue the main warning here and
	issue the secondary warning only when the value of the
	expression is not known at compile time.
	* sem_ch13.adb (Address_Clause_Check_Record): Add A component and
	adjust the description.
	(Analyze_Attribute_Definition_Clause): In the case
	of an address, move up the code creating an entry in the table of
	address clauses.  Also create an entry for an absolute address.
	(Validate_Address_Clauses): Issue the warning for absolute
	addresses here too.  Tweak condition associated with overlays
	for consistency.

From-SVN: r237688
This commit is contained in:
Arnaud Charlet 2016-06-22 12:05:04 +02:00
parent f24ea9120d
commit f26a3587a6
8 changed files with 182 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/ada/ChangeLog
View File

@ -1,3 +1,28 @@
2016-06-22 Hristian Kirtchev <kirtchev@adacore.com>
* lib-xref-spark_specific.adb, a-cuprqu.ads, sem_ch6.adb: Minor
reformatting.
2016-06-22 Eric Botcazou <ebotcazou@adacore.com>
* sem_util.ads (Address_Value): Declare new function.
* sem_util.adb (Address_Value): New function extracted
unmodified from Apply_Address_Clause_Check, which returns the
underlying value of the expression of an address clause.
* checks.adb (Compile_Time_Bad_Alignment): Delete.
(Apply_Address_Clause_Check): Call Address_Value on
the expression. Do not issue the main warning here and
issue the secondary warning only when the value of the
expression is not known at compile time.
* sem_ch13.adb (Address_Clause_Check_Record): Add A component and
adjust the description.
(Analyze_Attribute_Definition_Clause): In the case
of an address, move up the code creating an entry in the table of
address clauses. Also create an entry for an absolute address.
(Validate_Address_Clauses): Issue the warning for absolute
addresses here too. Tweak condition associated with overlays
for consistency.
2016-06-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Is_Predicate_Static): An inherited predicate

4
gcc/ada/a-cuprqu.ads
View File

@ -123,10 +123,10 @@ package Ada.Containers.Unbounded_Priority_Queues is
overriding function Peak_Use return Count_Type;
private
Q_Elems : Set;
Q_Elems : Set;
-- Elements of the queue
Max_Length : Count_Type := 0;
Max_Length : Count_Type := 0;
-- The current length of the queue is the Length of Q_Elems. This is the
-- maximum value of that, so far. Updated by Enqueue.

83
gcc/ada/checks.adb
View File

@ -638,36 +638,12 @@ package body Checks is
AC : constant Node_Id := Address_Clause (E);
Loc : constant Source_Ptr := Sloc (AC);
Typ : constant Entity_Id := Etype (E);
Aexp : constant Node_Id := Expression (AC);
Expr : Node_Id;
-- Address expression (not necessarily the same as Aexp, for example
-- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant).
procedure Compile_Time_Bad_Alignment;
-- Post error warnings when alignment is known to be incompatible. Note
-- that we do not go as far as inserting a raise of Program_Error since
-- this is an erroneous case, and it may happen that we are lucky and an
-- underaligned address turns out to be OK after all.
--------------------------------
-- Compile_Time_Bad_Alignment --
--------------------------------
procedure Compile_Time_Bad_Alignment is
begin
if Address_Clause_Overlay_Warnings then
Error_Msg_FE
("?o?specified address for& may be inconsistent with alignment",
Aexp, E);
Error_Msg_FE
("\?o?program execution may be erroneous (RM 13.3(27))",
Aexp, E);
Set_Address_Warning_Posted (AC);
end if;
end Compile_Time_Bad_Alignment;
-- Start of processing for Apply_Address_Clause_Check
begin
@ -690,43 +666,11 @@ package body Checks is
-- Obtain expression from address clause
Expr := Expression (AC);
Expr := Address_Value (Expression (AC));
-- The following loop digs for the real expression to use in the check
loop
-- For constant, get constant expression
if Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Constant
then
Expr := Constant_Value (Entity (Expr));
-- For unchecked conversion, get result to convert
elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
Expr := Expression (Expr);
-- For (common case) of To_Address call, get argument
elsif Nkind (Expr) = N_Function_Call
and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
Expr := First (Parameter_Associations (Expr));
if Nkind (Expr) = N_Parameter_Association then
Expr := Explicit_Actual_Parameter (Expr);
end if;
-- We finally have the real expression
else
exit;
end if;
end loop;
-- See if we know that Expr has a bad alignment at compile time
-- See if we know that Expr has an acceptable value at compile time. If
-- it hasn't or we don't know, we defer issuing the warning until the
-- end of the compilation to take into account back end annotations.
if Compile_Time_Known_Value (Expr)
and then (Known_Alignment (E) or else Known_Alignment (Typ))
@ -742,9 +686,7 @@ package body Checks is
AL := Alignment (E);
end if;
if Expr_Value (Expr) mod AL /= 0 then
Compile_Time_Bad_Alignment;
else
if Expr_Value (Expr) mod AL = 0 then
return;
end if;
end;
@ -818,12 +760,11 @@ package body Checks is
Warning_Msg := No_Error_Msg;
Analyze (First (Actions (N)), Suppress => All_Checks);
-- If the address clause generated a warning message (for example,
-- If the above raise action generated a warning message (for example
-- from Warn_On_Non_Local_Exception mode with the active restriction
-- No_Exception_Propagation).
if Warning_Msg /= No_Error_Msg then
-- If the expression has a known at compile time value, then
-- once we know the alignment of the type, we can check if the
-- exception will be raised or not, and if not, we don't need
@ -832,13 +773,13 @@ package body Checks is
if Compile_Time_Known_Value (Expr) then
Alignment_Warnings.Append
((E => E, A => Expr_Value (Expr), W => Warning_Msg));
else
-- Add explanation of the warning generated by the check
Error_Msg_N
("\address value may be incompatible with alignment "
& "of object?X?", AC);
end if;
-- Add explanation of the warning that is generated by the check
Error_Msg_N
("\address value may be incompatible with alignment "
& "of object?X?", AC);
end if;
return;

18
gcc/ada/lib-xref-spark_specific.adb
View File

@ -932,34 +932,34 @@ package body SPARK_Specific is
declare
Cunit1 : Node_Id renames Cunit (Sdep_Table (D1));
Cunit2 : Node_Id renames Cunit (Sdep_Table (D1 + 1));
begin
-- Both Cunit point to compilation unit nodes
pragma Assert (Nkind (Cunit1) = N_Compilation_Unit
and then
Nkind (Cunit2) = N_Compilation_Unit);
pragma Assert
(Nkind (Cunit1) = N_Compilation_Unit
and then Nkind (Cunit2) = N_Compilation_Unit);
-- Do not depend on the sorting order, which is based on
-- Unit_Name and for library-level instances of nested
-- generic-packages they are equal.
-- If declaration comes before the body then just set D2
if Nkind (Unit (Cunit1)) = N_Package_Declaration
and then
Nkind (Unit (Cunit2)) = N_Package_Body
and then Nkind (Unit (Cunit2)) = N_Package_Body
then
D2 := D1 + 1;
-- If body comes before declaration then set D2 and adjust D1
elsif Nkind (Unit (Cunit1)) = N_Package_Body
and then
Nkind (Unit (Cunit2)) = N_Package_Declaration
and then Nkind (Unit (Cunit2)) = N_Package_Declaration
then
D2 := D1;
D1 := D1 + 1;
else
raise Program_Error;
end if;
end;
@ -978,6 +978,8 @@ package body SPARK_Specific is
Dspec => D2);
end if;
-- ??? this needs a comment
D1 := Pos'Max (D1, D2) + 1;
end loop;

134
gcc/ada/sem_ch13.adb
View File

@ -273,9 +273,10 @@ package body Sem_Ch13 is
-- for X'Address use Expr
-- where Expr is of the form Y'Address or recursively is a reference to a
-- constant of either of these forms, and X and Y are entities of objects,
-- then if Y has a smaller alignment than X, that merits a warning about
-- where Expr has a value known at compile time or is of the form Y'Address
-- or recursively is a reference to a constant initialized with either of
-- these forms, and the value of Expr is not a multiple of X's alignment,
-- or if Y has a smaller alignment than X, then that merits a warning about
-- possible bad alignment. The following table collects address clauses of
-- this kind. We put these in a table so that they can be checked after the
-- back end has completed annotation of the alignments of objects, since we
@ -286,13 +287,16 @@ package body Sem_Ch13 is
-- The address clause
X : Entity_Id;
-- The entity of the object overlaying Y
-- The entity of the object subject to the address clause
A : Uint;
-- The value of the address in the first case
Y : Entity_Id;
-- The entity of the object being overlaid
-- The entity of the object being overlaid in the second case
Off : Boolean;
-- Whether the address is offset within Y
-- Whether the address is offset within Y in the second case
end record;
package Address_Clause_Checks is new Table.Table (
@ -4849,6 +4853,40 @@ package body Sem_Ch13 is
Set_Overlays_Constant (U_Ent);
end if;
-- If the address clause is of the form:
-- for X'Address use Y'Address;
-- or
-- C : constant Address := Y'Address;
-- ...
-- for X'Address use C;
-- then we make an entry in the table to check the size
-- and alignment of the overlaying variable. But we defer
-- this check till after code generation to take full
-- advantage of the annotation done by the back end.
-- If the entity has a generic type, the check will be
-- performed in the instance if the actual type justifies
-- it, and we do not insert the clause in the table to
-- prevent spurious warnings.
-- Note: we used to test Comes_From_Source and only give
-- this warning for source entities, but we have removed
-- this test. It really seems bogus to generate overlays
-- that would trigger this warning in generated code.
-- Furthermore, by removing the test, we handle the
-- aspect case properly.
if Is_Object (O_Ent)
and then not Is_Generic_Type (Etype (U_Ent))
and then Address_Clause_Overlay_Warnings
then
Address_Clause_Checks.Append
((N, U_Ent, No_Uint, O_Ent, Off));
end if;
else
-- If this is not an overlay, mark a variable as being
-- volatile to prevent unwanted optimizations. It's a
@ -4861,6 +4899,21 @@ package body Sem_Ch13 is
if Ekind (U_Ent) = E_Variable then
Set_Treat_As_Volatile (U_Ent);
end if;
-- Make an entry in the table for an absolute address as
-- above to check that the value is compatible with the
-- alignment of the object.
declare
Addr : constant Node_Id := Address_Value (Expr);
begin
if Compile_Time_Known_Value (Addr)
and then Address_Clause_Overlay_Warnings
then
Address_Clause_Checks.Append
((N, U_Ent, Expr_Value (Addr), Empty, False));
end if;
end;
end if;
-- Overlaying controlled objects is erroneous. Emit warning
@ -4950,41 +5003,6 @@ package body Sem_Ch13 is
-- the variable, it is somewhere else.
Kill_Size_Check_Code (U_Ent);
-- If the address clause is of the form:
-- for Y'Address use X'Address
-- or
-- Const : constant Address := X'Address;
-- ...
-- for Y'Address use Const;
-- then we make an entry in the table for checking the size
-- and alignment of the overlaying variable. We defer this
-- check till after code generation to take full advantage
-- of the annotation done by the back end.
-- If the entity has a generic type, the check will be
-- performed in the instance if the actual type justifies
-- it, and we do not insert the clause in the table to
-- prevent spurious warnings.
-- Note: we used to test Comes_From_Source and only give
-- this warning for source entities, but we have removed
-- this test. It really seems bogus to generate overlays
-- that would trigger this warning in generated code.
-- Furthermore, by removing the test, we handle the
-- aspect case properly.
if Present (O_Ent)
and then Is_Object (O_Ent)
and then not Is_Generic_Type (Etype (U_Ent))
and then Address_Clause_Overlay_Warnings
then
Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
end if;
end;
-- Not a valid entity for an address clause
@ -13183,15 +13201,15 @@ package body Sem_Ch13 is
if not Address_Warning_Posted (ACCR.N) then
Expr := Original_Node (Expression (ACCR.N));
-- Get alignments
-- Get alignments, sizes and offset, if any
X_Alignment := Alignment (ACCR.X);
Y_Alignment := Alignment (ACCR.Y);
-- Similarly obtain sizes and offset
X_Size := Esize (ACCR.X);
Y_Size := Esize (ACCR.Y);
if Present (ACCR.Y) then
Y_Alignment := Alignment (ACCR.Y);
Y_Size := Esize (ACCR.Y);
end if;
if ACCR.Off
and then Nkind (Expr) = N_Attribute_Reference
@ -13202,9 +13220,27 @@ package body Sem_Ch13 is
X_Offs := Uint_0;
end if;
-- Check for known value not multiple of alignment
if No (ACCR.Y) then
if not Alignment_Checks_Suppressed (ACCR.X)
and then X_Alignment /= 0
and then ACCR.A mod X_Alignment /= 0
then
Error_Msg_NE
("??specified address for& is inconsistent with "
& "alignment", ACCR.N, ACCR.X);
Error_Msg_N
("\??program execution may be erroneous (RM 13.3(27))",
ACCR.N);
Error_Msg_Uint_1 := X_Alignment;
Error_Msg_NE ("\??alignment of & is ^", ACCR.N, ACCR.X);
end if;
-- Check for large object overlaying smaller one
if Y_Size > Uint_0
elsif Y_Size > Uint_0
and then X_Size > Uint_0
and then X_Offs + X_Size > Y_Size
then
@ -13232,7 +13268,7 @@ package body Sem_Ch13 is
-- Note: we do not check the alignment if we gave a size
-- warning, since it would likely be redundant.
elsif not Alignment_Checks_Suppressed (ACCR.Y)
elsif not Alignment_Checks_Suppressed (ACCR.X)
and then Y_Alignment /= Uint_0
and then
(Y_Alignment < X_Alignment

4
gcc/ada/sem_ch6.adb
View File

@ -10808,8 +10808,8 @@ package body Sem_Ch6 is
and then not Is_Class_Wide_Type (Formal_Type)
then
if not Nkind_In
(Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition)
(Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition)
then
Append_Elmt (Current_Scope,
Private_Dependents (Base_Type (Formal_Type)));

43
gcc/ada/sem_util.adb
View File

@ -286,6 +286,49 @@ package body Sem_Util is
end if;
end Address_Integer_Convert_OK;
-------------------
-- Address_Value --
-------------------
function Address_Value (N : Node_Id) return Node_Id is
Expr : Node_Id := N;
begin
loop
-- For constant, get constant expression
if Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Constant
then
Expr := Constant_Value (Entity (Expr));
-- For unchecked conversion, get result to convert
elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
Expr := Expression (Expr);
-- For (common case) of To_Address call, get argument
elsif Nkind (Expr) = N_Function_Call
and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
Expr := First (Parameter_Associations (Expr));
if Nkind (Expr) = N_Parameter_Association then
Expr := Explicit_Actual_Parameter (Expr);
end if;
-- We finally have the real expression
else
exit;
end if;
end loop;
return Expr;
end Address_Value;
-----------------
-- Addressable --
-----------------

3
gcc/ada/sem_util.ads
View File

@ -65,6 +65,9 @@ package Sem_Util is
-- and one of the types is (a descendant of) System.Address (and this type
-- is private), and the other type is any integer type.
function Address_Value (N : Node_Id) return Node_Id;
-- Return the underlying value of the expression N of an address clause
function Addressable (V : Uint) return Boolean;
function Addressable (V : Int) return Boolean;
pragma Inline (Addressable);