+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
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.
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
-- 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))
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;
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
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;
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;
Dspec => D2);
end if;
+ -- ??? this needs a comment
+
D1 := Pos'Max (D1, D2) + 1;
end loop;
-- 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
-- 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 (
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
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
-- 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
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
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
-- 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
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)));
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 --
-----------------
-- 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);
projects / gcc.git / commitdiff