aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2016-06-22 12:05:04 +0200
committerArnaud Charlet <charlet@gcc.gnu.org>2016-06-22 12:05:04 +0200
commitf26a3587a6270640d7843ccdbfe9cc12379eba24 (patch)
tree44bc8267c9412d726ac51245ec3bb2935c5baca3 /gcc
parentf24ea9120d7b97d0b6b047de94865f7f190e6daa (diff)
downloadgcc-f26a3587a6270640d7843ccdbfe9cc12379eba24.zip
gcc-f26a3587a6270640d7843ccdbfe9cc12379eba24.tar.gz
gcc-f26a3587a6270640d7843ccdbfe9cc12379eba24.tar.bz2
[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
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/ChangeLog25
-rw-r--r--gcc/ada/a-cuprqu.ads4
-rw-r--r--gcc/ada/checks.adb83
-rw-r--r--gcc/ada/lib-xref-spark_specific.adb18
-rw-r--r--gcc/ada/sem_ch13.adb134
-rw-r--r--gcc/ada/sem_ch6.adb4
-rw-r--r--gcc/ada/sem_util.adb43
-rw-r--r--gcc/ada/sem_util.ads3
8 files changed, 182 insertions, 132 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0302b48..9368c08 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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
diff --git a/gcc/ada/a-cuprqu.ads b/gcc/ada/a-cuprqu.ads
index 44735e0..591673e 100644
--- a/gcc/ada/a-cuprqu.ads
+++ b/gcc/ada/a-cuprqu.ads
@@ -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.
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index cd8d144..157bd06 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -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);
-
- -- 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
+ Expr := Address_Value (Expression (AC));
- 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));
- end if;
-
- -- Add explanation of the warning that is generated by the check
+ else
+ -- Add explanation of the warning generated by the check
- Error_Msg_N
- ("\address value may be incompatible with alignment "
- & "of object?X?", AC);
+ Error_Msg_N
+ ("\address value may be incompatible with alignment "
+ & "of object?X?", AC);
+ end if;
end if;
return;
diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb
index ce4ded8..fca2eea 100644
--- a/gcc/ada/lib-xref-spark_specific.adb
+++ b/gcc/ada/lib-xref-spark_specific.adb
@@ -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;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 599ce45..3c1c1b6 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -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
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 0a60d04..81b0ca7 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -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)));
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index de0f987..8ff3535 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -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 --
-----------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index d0bb92d..711c321 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -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);