Skip to content

R
riscv-gcc-1
Commit f26a3587 by Arnaud Charlet
Options

[multiple changes] 

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
parent f24ea912
Showing with 182 additions and 132 deletions
gcc/ada/ChangeLog
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> 2016-06-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Is_Predicate_Static): An inherited predicate * sem_ch13.adb (Is_Predicate_Static): An inherited predicate
......
gcc/ada/a-cuprqu.ads
...@@ -123,10 +123,10 @@ package Ada.Containers.Unbounded_Priority_Queues is ...@@ -123,10 +123,10 @@ package Ada.Containers.Unbounded_Priority_Queues is
overriding function Peak_Use return Count_Type; overriding function Peak_Use return Count_Type;
private private
Q_Elems : Set; Q_Elems : Set;
-- Elements of the queue -- 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 -- The current length of the queue is the Length of Q_Elems. This is the
-- maximum value of that, so far. Updated by Enqueue. -- maximum value of that, so far. Updated by Enqueue.
......
gcc/ada/checks.adb
...@@ -638,36 +638,12 @@ package body Checks is ...@@ -638,36 +638,12 @@ package body Checks is
AC : constant Node_Id := Address_Clause (E); AC : constant Node_Id := Address_Clause (E);
Loc : constant Source_Ptr := Sloc (AC); Loc : constant Source_Ptr := Sloc (AC);
Typ : constant Entity_Id := Etype (E); Typ : constant Entity_Id := Etype (E);
Aexp : constant Node_Id := Expression (AC);
Expr : Node_Id; Expr : Node_Id;
-- Address expression (not necessarily the same as Aexp, for example -- Address expression (not necessarily the same as Aexp, for example
-- when Aexp is a reference to a constant, in which case Expr gets -- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant). -- 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 -- Start of processing for Apply_Address_Clause_Check
begin begin
...@@ -690,43 +666,11 @@ package body Checks is ...@@ -690,43 +666,11 @@ package body Checks is
-- Obtain expression from address clause -- 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 -- See if we know that Expr has an acceptable value at compile time. If
Expr := Expression (Expr); -- 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.
-- 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
if Compile_Time_Known_Value (Expr) if Compile_Time_Known_Value (Expr)
and then (Known_Alignment (E) or else Known_Alignment (Typ)) and then (Known_Alignment (E) or else Known_Alignment (Typ))
...@@ -742,9 +686,7 @@ package body Checks is ...@@ -742,9 +686,7 @@ package body Checks is
AL := Alignment (E); AL := Alignment (E);
end if; end if;
if Expr_Value (Expr) mod AL /= 0 then if Expr_Value (Expr) mod AL = 0 then
Compile_Time_Bad_Alignment;
else
return; return;
end if; end if;
end; end;
...@@ -818,12 +760,11 @@ package body Checks is ...@@ -818,12 +760,11 @@ package body Checks is
Warning_Msg := No_Error_Msg; Warning_Msg := No_Error_Msg;
Analyze (First (Actions (N)), Suppress => All_Checks); 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 -- from Warn_On_Non_Local_Exception mode with the active restriction
-- No_Exception_Propagation). -- No_Exception_Propagation).
if Warning_Msg /= No_Error_Msg then if Warning_Msg /= No_Error_Msg then
-- If the expression has a known at compile time value, 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 -- 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 -- exception will be raised or not, and if not, we don't need
...@@ -832,13 +773,13 @@ package body Checks is ...@@ -832,13 +773,13 @@ package body Checks is
if Compile_Time_Known_Value (Expr) then if Compile_Time_Known_Value (Expr) then
Alignment_Warnings.Append Alignment_Warnings.Append
((E => E, A => Expr_Value (Expr), W => Warning_Msg)); ((E => E, A => Expr_Value (Expr), W => Warning_Msg));
end if; else
-- Add explanation of the warning generated by the check
-- Add explanation of the warning that is generated by the check
Error_Msg_N Error_Msg_N
("\address value may be incompatible with alignment " ("\address value may be incompatible with alignment "
& "of object?X?", AC); & "of object?X?", AC);
end if;
end if; end if;
return; return;
......
gcc/ada/lib-xref-spark_specific.adb
...@@ -932,34 +932,34 @@ package body SPARK_Specific is ...@@ -932,34 +932,34 @@ package body SPARK_Specific is
declare declare
Cunit1 : Node_Id renames Cunit (Sdep_Table (D1)); Cunit1 : Node_Id renames Cunit (Sdep_Table (D1));
Cunit2 : Node_Id renames Cunit (Sdep_Table (D1 + 1)); Cunit2 : Node_Id renames Cunit (Sdep_Table (D1 + 1));
begin begin
-- Both Cunit point to compilation unit nodes -- Both Cunit point to compilation unit nodes
pragma Assert (Nkind (Cunit1) = N_Compilation_Unit
and then pragma Assert
Nkind (Cunit2) = N_Compilation_Unit); (Nkind (Cunit1) = N_Compilation_Unit
and then Nkind (Cunit2) = N_Compilation_Unit);
-- Do not depend on the sorting order, which is based on -- Do not depend on the sorting order, which is based on
-- Unit_Name and for library-level instances of nested -- Unit_Name and for library-level instances of nested
-- generic-packages they are equal. -- generic-packages they are equal.
-- If declaration comes before the body then just set D2 -- If declaration comes before the body then just set D2
if Nkind (Unit (Cunit1)) = N_Package_Declaration if Nkind (Unit (Cunit1)) = N_Package_Declaration
and then and then Nkind (Unit (Cunit2)) = N_Package_Body
Nkind (Unit (Cunit2)) = N_Package_Body
then then
D2 := D1 + 1; D2 := D1 + 1;
-- If body comes before declaration then set D2 and adjust D1 -- If body comes before declaration then set D2 and adjust D1
elsif Nkind (Unit (Cunit1)) = N_Package_Body elsif Nkind (Unit (Cunit1)) = N_Package_Body
and then and then Nkind (Unit (Cunit2)) = N_Package_Declaration
Nkind (Unit (Cunit2)) = N_Package_Declaration
then then
D2 := D1; D2 := D1;
D1 := D1 + 1; D1 := D1 + 1;
else else
raise Program_Error; raise Program_Error;
end if; end if;
end; end;
...@@ -978,6 +978,8 @@ package body SPARK_Specific is ...@@ -978,6 +978,8 @@ package body SPARK_Specific is
Dspec => D2); Dspec => D2);
end if; end if;
-- ??? this needs a comment
D1 := Pos'Max (D1, D2) + 1; D1 := Pos'Max (D1, D2) + 1;
end loop; end loop;
......
gcc/ada/sem_ch13.adb
...@@ -273,9 +273,10 @@ package body Sem_Ch13 is ...@@ -273,9 +273,10 @@ package body Sem_Ch13 is
-- for X'Address use Expr -- for X'Address use Expr
-- where Expr is of the form Y'Address or recursively is a reference to a -- where Expr has a value known at compile time or is of the form Y'Address
-- constant of either of these forms, and X and Y are entities of objects, -- or recursively is a reference to a constant initialized with either of
-- then if Y has a smaller alignment than X, that merits a warning about -- 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 -- 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 -- 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 -- back end has completed annotation of the alignments of objects, since we
...@@ -286,13 +287,16 @@ package body Sem_Ch13 is ...@@ -286,13 +287,16 @@ package body Sem_Ch13 is
-- The address clause -- The address clause
X : Entity_Id; 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; Y : Entity_Id;
-- The entity of the object being overlaid -- The entity of the object being overlaid in the second case
Off : Boolean; Off : Boolean;
-- Whether the address is offset within Y -- Whether the address is offset within Y in the second case
end record; end record;
package Address_Clause_Checks is new Table.Table ( package Address_Clause_Checks is new Table.Table (
...@@ -4849,6 +4853,40 @@ package body Sem_Ch13 is ...@@ -4849,6 +4853,40 @@ package body Sem_Ch13 is
Set_Overlays_Constant (U_Ent); Set_Overlays_Constant (U_Ent);
end if; 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 else
-- If this is not an overlay, mark a variable as being -- If this is not an overlay, mark a variable as being
-- volatile to prevent unwanted optimizations. It's a -- volatile to prevent unwanted optimizations. It's a
...@@ -4861,6 +4899,21 @@ package body Sem_Ch13 is ...@@ -4861,6 +4899,21 @@ package body Sem_Ch13 is
if Ekind (U_Ent) = E_Variable then if Ekind (U_Ent) = E_Variable then
Set_Treat_As_Volatile (U_Ent); Set_Treat_As_Volatile (U_Ent);
end if; 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; end if;
-- Overlaying controlled objects is erroneous. Emit warning -- Overlaying controlled objects is erroneous. Emit warning
...@@ -4950,41 +5003,6 @@ package body Sem_Ch13 is ...@@ -4950,41 +5003,6 @@ package body Sem_Ch13 is
-- the variable, it is somewhere else. -- the variable, it is somewhere else.
Kill_Size_Check_Code (U_Ent); 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; end;
-- Not a valid entity for an address clause -- Not a valid entity for an address clause
...@@ -13183,15 +13201,15 @@ package body Sem_Ch13 is ...@@ -13183,15 +13201,15 @@ package body Sem_Ch13 is
if not Address_Warning_Posted (ACCR.N) then if not Address_Warning_Posted (ACCR.N) then
Expr := Original_Node (Expression (ACCR.N)); Expr := Original_Node (Expression (ACCR.N));
-- Get alignments -- Get alignments, sizes and offset, if any
X_Alignment := Alignment (ACCR.X); X_Alignment := Alignment (ACCR.X);
Y_Alignment := Alignment (ACCR.Y);
-- Similarly obtain sizes and offset
X_Size := Esize (ACCR.X); 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 if ACCR.Off
and then Nkind (Expr) = N_Attribute_Reference and then Nkind (Expr) = N_Attribute_Reference
...@@ -13202,9 +13220,27 @@ package body Sem_Ch13 is ...@@ -13202,9 +13220,27 @@ package body Sem_Ch13 is
X_Offs := Uint_0; X_Offs := Uint_0;
end if; 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 -- 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_Size > Uint_0
and then X_Offs + X_Size > Y_Size and then X_Offs + X_Size > Y_Size
then then
...@@ -13232,7 +13268,7 @@ package body Sem_Ch13 is ...@@ -13232,7 +13268,7 @@ package body Sem_Ch13 is
-- Note: we do not check the alignment if we gave a size -- Note: we do not check the alignment if we gave a size
-- warning, since it would likely be redundant. -- 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 /= Uint_0
and then and then
(Y_Alignment < X_Alignment (Y_Alignment < X_Alignment
......
gcc/ada/sem_ch6.adb
...@@ -10808,8 +10808,8 @@ package body Sem_Ch6 is ...@@ -10808,8 +10808,8 @@ package body Sem_Ch6 is
and then not Is_Class_Wide_Type (Formal_Type) and then not Is_Class_Wide_Type (Formal_Type)
then then
if not Nkind_In if not Nkind_In
(Parent (T), N_Access_Function_Definition, (Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition) N_Access_Procedure_Definition)
then then
Append_Elmt (Current_Scope, Append_Elmt (Current_Scope,
Private_Dependents (Base_Type (Formal_Type))); Private_Dependents (Base_Type (Formal_Type)));
......
gcc/ada/sem_util.adb
...@@ -286,6 +286,49 @@ package body Sem_Util is ...@@ -286,6 +286,49 @@ package body Sem_Util is
end if; end if;
end Address_Integer_Convert_OK; 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 -- -- Addressable --
----------------- -----------------
......
gcc/ada/sem_util.ads
...@@ -65,6 +65,9 @@ package Sem_Util is ...@@ -65,6 +65,9 @@ package Sem_Util is
-- and one of the types is (a descendant of) System.Address (and this type -- and one of the types is (a descendant of) System.Address (and this type
-- is private), and the other type is any integer 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 : Uint) return Boolean;
function Addressable (V : Int) return Boolean; function Addressable (V : Int) return Boolean;
pragma Inline (Addressable); pragma Inline (Addressable);
......
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