Skip to content

R
riscv-gcc-1
Commit f4cd2542 by Eric Botcazou Committed by Eric Botcazou
Options

checks.adb (Apply_Address_Clause_Check): Remove Size_Warning_Output local… 

checks.adb (Apply_Address_Clause_Check): Remove Size_Warning_Output local variable and do not test it in...

	* checks.adb (Apply_Address_Clause_Check): Remove Size_Warning_Output
	local variable and do not test it in Compile_Time_Bad_Alignment.
	Do not issue size or alignment warnings for the X'Address form.
	* sem_util.ads (Find_Overlaid_Object): Delete.
	(Find_Overlaid_Entity): New procedure.
	* sem_util.adb (Find_Overlaid_Object): Rename to...
	(Find_Overlaid_Entity): ...this and turn into a procedure.  Report
	whether the address is offseted within the overlaid entity.
	(Has_Compatible_Alignment): Track the offset globally instead of
	passing it to Check_Offset.  For an indexed component, compute the
	full offset when possible.  If the resulting offset is zero, only
	check the prefix.
	(Check_Offset): Delete.
	* sem_ch13.adb (Address_Clause_Check_Record): Add Off field.
	(Address_Aliased_Entity): Delete.
	(Analyze_Attribute_Definition_Clause) <Attribute_Address>: Call
	Find_Overlaid_Entity to find the overlaid entity and the offset.
	Adjust throughout for above change.
	(Validate_Address_Clauses): Always use attributes of entities, not of
	their type.  Tweak message for warning.  Call Has_Compatible_Alignment
	if the address is offseted to warn about incompatible alignments.
	* gcc-interface/gigi.h (annotate_object): Declare.
	* gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Annotate renaming
	entity.  Call annotate_object instead of annotating manually objects.
	(annotate_object): New function.
	* gcc-interface/trans.c (Subprogram_Body_to_gnu): Annotate parameters
	at the end.

From-SVN: r149520
parent 97c281da
Showing with 361 additions and 307 deletions
gcc/ada/ChangeLog
2009-07-11 Eric Botcazou <ebotcazou@adacore.com>
* checks.adb (Apply_Address_Clause_Check): Remove Size_Warning_Output
local variable and do not test it in Compile_Time_Bad_Alignment.
Do not issue size or alignment warnings for the X'Address form.
* sem_util.ads (Find_Overlaid_Object): Delete.
(Find_Overlaid_Entity): New procedure.
* sem_util.adb (Find_Overlaid_Object): Rename to...
(Find_Overlaid_Entity): ...this and turn into a procedure. Report
whether the address is offseted within the overlaid entity.
(Has_Compatible_Alignment): Track the offset globally instead of
passing it to Check_Offset. For an indexed component, compute the
full offset when possible. If the resulting offset is zero, only
check the prefix.
(Check_Offset): Delete.
* sem_ch13.adb (Address_Clause_Check_Record): Add Off field.
(Address_Aliased_Entity): Delete.
(Analyze_Attribute_Definition_Clause) <Attribute_Address>: Call
Find_Overlaid_Entity to find the overlaid entity and the offset.
Adjust throughout for above change.
(Validate_Address_Clauses): Always use attributes of entities, not of
their type. Tweak message for warning. Call Has_Compatible_Alignment
if the address is offseted to warn about incompatible alignments.
* gcc-interface/gigi.h (annotate_object): Declare.
* gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Annotate renaming
entity. Call annotate_object instead of annotating manually objects.
(annotate_object): New function.
* gcc-interface/trans.c (Subprogram_Body_to_gnu): Annotate parameters
at the end.
2009-07-11 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/ada-tree.h: Minor reorganization.
* gcc-interface/misc.c (gnat_print_decl): Minor tweaks.
(gnat_print_type): Likewise.
......
gcc/ada/checks.adb
......@@ -532,16 +532,11 @@ package body Checks is
-- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant.
Size_Warning_Output : Boolean := False;
-- If we output a size warning we set this True, to stop generating
-- what is likely to be an unuseful redundant alignment warning.
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. Also this warning
-- is suppressed if we already complained about the size.
-- underaligned address turns out to be OK after all.
--------------------------------
-- Compile_Time_Bad_Alignment --
......@@ -549,9 +544,7 @@ package body Checks is
procedure Compile_Time_Bad_Alignment is
begin
if not Size_Warning_Output
and then Address_Clause_Overlay_Warnings
then
if Address_Clause_Overlay_Warnings then
Error_Msg_FE
("?specified address for& may be inconsistent with alignment ",
Aexp, E);
......@@ -565,7 +558,24 @@ package body Checks is
-- Start of processing for Apply_Address_Clause_Check
begin
-- First obtain expression from address clause
-- See if alignment check needed. Note that we never need a check if the
-- maximum alignment is one, since the check will always succeed.
-- Note: we do not check for checks suppressed here, since that check
-- was done in Sem_Ch13 when the address clause was processed. We are
-- only called if checks were not suppressed. The reason for this is
-- that we have to delay the call to Apply_Alignment_Check till freeze
-- time (so that all types etc are elaborated), but we have to check
-- the status of check suppressing at the point of the address clause.
if No (AC)
or else not Check_Address_Alignment (AC)
or else Maximum_Alignment = 1
then
return;
end if;
-- Obtain expression from address clause
Expr := Expression (AC);
......@@ -603,69 +613,7 @@ package body Checks is
end if;
end loop;
-- Output a warning if we have the situation of
-- for X'Address use Y'Address
-- and X and Y both have known object sizes, and Y is smaller than X
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
and then Is_Entity_Name (Prefix (Expr))
then
declare
Exp_Ent : constant Entity_Id := Entity (Prefix (Expr));
Obj_Size : Uint := No_Uint;
Exp_Size : Uint := No_Uint;
begin
if Known_Esize (E) then
Obj_Size := Esize (E);
elsif Known_Esize (Etype (E)) then
Obj_Size := Esize (Etype (E));
end if;
if Known_Esize (Exp_Ent) then
Exp_Size := Esize (Exp_Ent);
elsif Known_Esize (Etype (Exp_Ent)) then
Exp_Size := Esize (Etype (Exp_Ent));
end if;
if Obj_Size /= No_Uint
and then Exp_Size /= No_Uint
and then Obj_Size > Exp_Size
and then not Has_Warnings_Off (E)
then
if Address_Clause_Overlay_Warnings then
Error_Msg_FE
("?& overlays smaller object", Aexp, E);
Error_Msg_FE
("\?program execution may be erroneous", Aexp, E);
Size_Warning_Output := True;
Set_Address_Warning_Posted (AC);
end if;
end if;
end;
end if;
-- See if alignment check needed. Note that we never need a check if the
-- maximum alignment is one, since the check will always succeed.
-- Note: we do not check for checks suppressed here, since that check
-- was done in Sem_Ch13 when the address clause was processed. We are
-- only called if checks were not suppressed. The reason for this is
-- that we have to delay the call to Apply_Alignment_Check till freeze
-- time (so that all types etc are elaborated), but we have to check
-- the status of check suppressing at the point of the address clause.
if No (AC)
or else not Check_Address_Alignment (AC)
or else Maximum_Alignment = 1
then
return;
end if;
-- See if we know that Expr is a bad alignment at compile time
-- See if we know that Expr has a bad alignment at compile time
if Compile_Time_Known_Value (Expr)
and then (Known_Alignment (E) or else Known_Alignment (Typ))
......@@ -690,20 +638,14 @@ package body Checks is
-- If the expression has the form X'Address, then we can find out if
-- the object X has an alignment that is compatible with the object E.
-- 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.
elsif Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
and then Has_Compatible_Alignment (E, Prefix (Expr)) = Known_Compatible
then
declare
AR : constant Alignment_Result :=
Has_Compatible_Alignment (E, Prefix (Expr));
begin
if AR = Known_Compatible then
return;
elsif AR = Known_Incompatible then
Compile_Time_Bad_Alignment;
end if;
end;
return;
end if;
-- Here we do not know if the value is acceptable. Stricly we don't have
......
gcc/ada/gcc-interface/decl.c
......@@ -905,6 +905,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
mark_visited (&gnu_decl);
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
annotate_object (gnat_entity, gnu_type, NULL_TREE,
false);
break;
}
......@@ -1382,32 +1384,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& Exception_Mechanism != Back_End_Exceptions)
TREE_ADDRESSABLE (gnu_decl) = 1;
gnu_type = TREE_TYPE (gnu_decl);
/* Back-annotate Alignment and Esize of the object if not already
known, except for when the object is actually a pointer to the
real object, since alignment and size of a pointer don't have
anything to do with those of the designated object. Note that
we pick the values of the type, not those of the object, to
shield ourselves from low-level platform-dependent adjustments
like alignment promotion. This is both consistent with all the
treatment above, where alignment and size are set on the type of
the object and not on the object directly, and makes it possible
to support confirming representation clauses in all cases. */
if (!used_by_ref && Unknown_Alignment (gnat_entity))
Set_Alignment (gnat_entity,
UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
if (!used_by_ref && Unknown_Esize (gnat_entity))
{
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
gnu_object_size
= TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
Set_Esize (gnat_entity, annotate_value (gnu_object_size));
}
/* Back-annotate Esize and Alignment of the object if not already
known. Note that we pick the values of the type, not those of
the object, to shield ourselves from low-level platform-dependent
adjustments like alignment promotion. This is both consistent with
all the treatment above, where alignment and size are set on the
type of the object and not on the object directly, and makes it
possible to support all confirming representation clauses. */
annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
used_by_ref);
}
break;
......@@ -7223,6 +7208,39 @@ annotate_value (tree gnu_size)
return ret;
}
/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
BY_REF is true if the object is used by reference. */
void
annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
{
if (by_ref)
{
if (TYPE_FAT_POINTER_P (gnu_type))
gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
else
gnu_type = TREE_TYPE (gnu_type);
}
if (Unknown_Esize (gnat_entity))
{
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
size = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
else if (!size)
size = TYPE_SIZE (gnu_type);
if (size)
Set_Esize (gnat_entity, annotate_value (size));
}
if (Unknown_Alignment (gnat_entity))
Set_Alignment (gnat_entity,
UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
}
/* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
GCC type, set Component_Bit_Offset and Esize to the position and size
used by Gigi. */
......
gcc/ada/gcc-interface/gigi.h
......@@ -135,6 +135,13 @@ extern tree maybe_pad_type (tree type, tree size, unsigned int align,
the value passed against the list of choices. */
extern tree choices_to_gnu (tree operand, Node_Id choices);
/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
BY_REF is true if the object is used by reference. */
extern void annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size,
bool by_ref);
/* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
type with all size expressions that contain F updated by replacing F
with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
......
gcc/ada/gcc-interface/trans.c
......@@ -2328,13 +2328,18 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
end_subprog_body (gnu_result, false);
/* Disconnect the trees for parameters that we made variables for from the
GNAT entities since these are unusable after we end the function. */
/* Finally annotate the parameters and disconnect the trees for parameters
that we have turned into variables since they are now unusable. */
for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param))
if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
save_gnu_tree (gnat_param, NULL_TREE, false);
{
tree gnu_param = get_gnu_tree (gnat_param);
annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
DECL_BY_REF_P (gnu_param));
if (TREE_CODE (gnu_param) == VAR_DECL)
save_gnu_tree (gnat_param, NULL_TREE, false);
}
if (DECL_FUNCTION_STUB (gnu_subprog_decl))
build_function_stub (gnu_subprog_decl, gnat_subprog_id);
......
gcc/ada/sem_ch13.adb
......@@ -87,9 +87,6 @@ package body Sem_Ch13 is
-- Attributes that do not specify a representation characteristic are
-- operational attributes.
function Address_Aliased_Entity (N : Node_Id) return Entity_Id;
-- If expression N is of the form E'Address, return E
procedure New_Stream_Subprogram
(N : Node_Id;
Ent : Entity_Id;
......@@ -164,6 +161,9 @@ package body Sem_Ch13 is
Y : Entity_Id;
-- The entity of the object being overlaid
Off : Boolean;
-- Whether the address is offseted within Y
end record;
package Address_Clause_Checks is new Table.Table (
......@@ -174,33 +174,6 @@ package body Sem_Ch13 is
Table_Increment => 200,
Table_Name => "Address_Clause_Checks");
----------------------------
-- Address_Aliased_Entity --
----------------------------
function Address_Aliased_Entity (N : Node_Id) return Entity_Id is
begin
if Nkind (N) = N_Attribute_Reference
and then Attribute_Name (N) = Name_Address
then
declare
P : Node_Id;
begin
P := Prefix (N);
while Nkind_In (P, N_Selected_Component, N_Indexed_Component) loop
P := Prefix (P);
end loop;
if Is_Entity_Name (P) then
return Entity (P);
end if;
end;
end if;
return Empty;
end Address_Aliased_Entity;
-----------------------------------------
-- Adjust_Record_For_Reverse_Bit_Order --
-----------------------------------------
......@@ -906,11 +879,12 @@ package body Sem_Ch13 is
Ekind (U_Ent) = E_Constant
then
declare
Expr : constant Node_Id := Expression (N);
Aent : constant Entity_Id := Address_Aliased_Entity (Expr);
Ent_Y : constant Entity_Id := Find_Overlaid_Object (N);
Expr : constant Node_Id := Expression (N);
O_Ent : Entity_Id;
Off : Boolean;
begin
-- Exported variables cannot have an address clause,
-- because this cancels the effect of the pragma Export
......@@ -918,12 +892,15 @@ package body Sem_Ch13 is
Error_Msg_N
("cannot export object with address clause", Nam);
return;
end if;
Find_Overlaid_Entity (N, O_Ent, Off);
-- Overlaying controlled objects is erroneous
elsif Present (Aent)
and then (Has_Controlled_Component (Etype (Aent))
or else Is_Controlled (Etype (Aent)))
if Present (O_Ent)
and then (Has_Controlled_Component (Etype (O_Ent))
or else Is_Controlled (Etype (O_Ent)))
then
Error_Msg_N
("?cannot overlay with controlled object", Expr);
......@@ -934,9 +911,9 @@ package body Sem_Ch13 is
Reason => PE_Overlaid_Controlled_Object));
return;
elsif Present (Aent)
elsif Present (O_Ent)
and then Ekind (U_Ent) = E_Constant
and then not Is_Constant_Object (Aent)
and then not Is_Constant_Object (O_Ent)
then
Error_Msg_N ("constant overlays a variable?", Expr);
......@@ -964,10 +941,15 @@ package body Sem_Ch13 is
-- Here we are checking for explicit overlap of one variable
-- by another, and if we find this then mark the overlapped
-- variable as also being volatile to prevent unwanted
-- optimizations.
-- optimizations. This is a significant pessimization so
-- avoid it when there is an offset, i.e. when the object
-- is composite; they cannot be optimized easily anyway.
if Present (Ent_Y) then
Set_Treat_As_Volatile (Ent_Y);
if Present (O_Ent)
and then Is_Object (O_Ent)
and then not Off
then
Set_Treat_As_Volatile (O_Ent);
end if;
-- Legality checks on the address clause for initialized
......@@ -1015,53 +997,42 @@ package body Sem_Ch13 is
-- the variable, it is somewhere else.
Kill_Size_Check_Code (U_Ent);
end;
-- If the address clause is of the form:
-- for Y'Address use X'Address
-- or
-- If the address clause is of the form:
-- Const : constant Address := X'Address;
-- ...
-- for Y'Address use Const;
-- for Y'Address use X'Address
-- 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. This entry is only made if
-- we have not already posted a warning about size/alignment
-- (some warnings of this type are posted in Checks), and if
-- the address clause comes from source.
-- or
if Address_Clause_Overlay_Warnings
and then Comes_From_Source (N)
then
declare
Ent_X : Entity_Id := Empty;
Ent_Y : Entity_Id := Empty;
-- Const : constant Address := X'Address;
-- ...
-- for Y'Address use Const;
begin
Ent_Y := Find_Overlaid_Object (N);
-- 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. This entry is
-- only made if the address clause comes from source.
if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then
Ent_X := Entity (Name (N));
Address_Clause_Checks.Append ((N, Ent_X, Ent_Y));
if Address_Clause_Overlay_Warnings
and then Comes_From_Source (N)
and then Present (O_Ent)
and then Is_Object (O_Ent)
then
Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
-- If variable overlays a constant view, and we are
-- warning on overlays, then mark the variable as
-- overlaying a constant (we will give warnings later
-- if this variable is assigned).
-- If variable overlays a constant view, and we are
-- warning on overlays, then mark the variable as
-- overlaying a constant (we will give warnings later
-- if this variable is assigned).
if Is_Constant_Object (Ent_Y)
and then Ekind (Ent_X) = E_Variable
then
Set_Overlays_Constant (Ent_X);
end if;
if Is_Constant_Object (O_Ent)
and then Ekind (U_Ent) = E_Variable
then
Set_Overlays_Constant (U_Ent);
end if;
end;
end if;
end if;
end;
-- Not a valid entity for an address clause
......@@ -4255,6 +4226,8 @@ package body Sem_Ch13 is
ACCR : Address_Clause_Check_Record
renames Address_Clause_Checks.Table (J);
Expr : Node_Id;
X_Alignment : Uint;
Y_Alignment : Uint;
......@@ -4266,35 +4239,17 @@ package body Sem_Ch13 is
if not Address_Warning_Posted (ACCR.N) then
-- Get alignments. Really we should always have the alignment
-- of the objects properly back annotated, but right now the
-- back end fails to back annotate for address clauses???
Expr := Original_Node (Expression (ACCR.N));
if Known_Alignment (ACCR.X) then
X_Alignment := Alignment (ACCR.X);
else
X_Alignment := Alignment (Etype (ACCR.X));
end if;
-- Get alignments
if Known_Alignment (ACCR.Y) then
Y_Alignment := Alignment (ACCR.Y);
else
Y_Alignment := Alignment (Etype (ACCR.Y));
end if;
X_Alignment := Alignment (ACCR.X);
Y_Alignment := Alignment (ACCR.Y);
-- Similarly obtain sizes
if Known_Esize (ACCR.X) then
X_Size := Esize (ACCR.X);
else
X_Size := Esize (Etype (ACCR.X));
end if;
if Known_Esize (ACCR.Y) then
Y_Size := Esize (ACCR.Y);
else
Y_Size := Esize (Etype (ACCR.Y));
end if;
X_Size := Esize (ACCR.X);
Y_Size := Esize (ACCR.Y);
-- Check for large object overlaying smaller one
......@@ -4302,8 +4257,10 @@ package body Sem_Ch13 is
and then X_Size > Uint_0
and then X_Size > Y_Size
then
Error_Msg_NE
("?& overlays smaller object", ACCR.N, ACCR.X);
Error_Msg_N
("?size for overlaid object is too small", ACCR.N);
("\?program execution may be erroneous", ACCR.N);
Error_Msg_Uint_1 := X_Size;
Error_Msg_NE
("\?size of & is ^", ACCR.N, ACCR.X);
......@@ -4311,16 +4268,23 @@ package body Sem_Ch13 is
Error_Msg_NE
("\?size of & is ^", ACCR.N, ACCR.Y);
-- Check for inadequate alignment. Again the defensive check
-- on Y_Alignment should not be needed, but because of the
-- failure in back end annotation, we can have an alignment
-- of 0 here???
-- Check for inadequate alignment, both of the base object
-- and of the offset, if any.
-- Note: we do not check alignments if we gave a size
-- warning, since it would likely be redundant.
-- Note: we do not check the alignment if we gave a size
-- warning, since it would likely be redundant.
elsif Y_Alignment /= Uint_0
and then Y_Alignment < X_Alignment
and then (Y_Alignment < X_Alignment
or else (ACCR.Off
and then
Nkind (Expr) = N_Attribute_Reference
and then
Attribute_Name (Expr) = Name_Address
and then
Has_Compatible_Alignment
(ACCR.X, Prefix (Expr))
/= Known_Compatible))
then
Error_Msg_NE
("?specified address for& may be inconsistent "
......@@ -4337,6 +4301,11 @@ package body Sem_Ch13 is
Error_Msg_NE
("\?alignment of & is ^",
ACCR.N, ACCR.Y);
if Y_Alignment >= X_Alignment then
Error_Msg_N
("\?but offset is not multiple of alignment",
ACCR.N);
end if;
end if;
end if;
end;
......
gcc/ada/sem_util.adb
......@@ -2892,11 +2892,15 @@ package body Sem_Util is
end Find_Corresponding_Discriminant;
--------------------------
-- Find_Overlaid_Object --
-- Find_Overlaid_Entity --
--------------------------
function Find_Overlaid_Object (N : Node_Id) return Entity_Id is
Expr : Node_Id;
procedure Find_Overlaid_Entity
(N : Node_Id;
Ent : out Entity_Id;
Off : out Boolean)
is
Expr : Node_Id;
begin
-- We are looking for one of the two following forms:
......@@ -2912,24 +2916,25 @@ package body Sem_Util is
-- In the second case, the expr is either Y'Address, or recursively a
-- constant that eventually references Y'Address.
Ent := Empty;
Off := False;
if Nkind (N) = N_Attribute_Definition_Clause
and then Chars (N) = Name_Address
then
-- This loop checks the form of the expression for Y'Address where Y
-- is an object entity name. The first loop checks the original
-- expression in the attribute definition clause. Subsequent loops
-- check referenced constants.
Expr := Expression (N);
-- This loop checks the form of the expression for Y'Address,
-- using recursion to deal with intermediate constants.
loop
-- Check for Y'Address where Y is an object entity
-- Check for Y'Address
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
and then Is_Entity_Name (Prefix (Expr))
and then Is_Object (Entity (Prefix (Expr)))
then
return Entity (Prefix (Expr));
Expr := Prefix (Expr);
exit;
-- Check for Const where Const is a constant entity
......@@ -2941,13 +2946,36 @@ package body Sem_Util is
-- Anything else does not need checking
else
exit;
return;
end if;
end loop;
end if;
return Empty;
end Find_Overlaid_Object;
-- This loop checks the form of the prefix for an entity,
-- using recursion to deal with intermediate components.
loop
-- Check for Y where Y is an entity
if Is_Entity_Name (Expr) then
Ent := Entity (Expr);
return;
-- Check for components
elsif
Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then
Expr := Prefix (Expr);
Off := True;
-- Anything else does not need checking
else
return;
end if;
end loop;
end if;
end Find_Overlaid_Entity;
-------------------------
-- Find_Parameter_Type --
......@@ -3829,16 +3857,16 @@ package body Sem_Util is
Default : Alignment_Result) return Alignment_Result
is
Result : Alignment_Result := Known_Compatible;
-- Set to result if Problem_Prefix or Problem_Offset returns True.
-- Note that once a value of Known_Incompatible is set, it is sticky
-- and does not get changed to Unknown (the value in Result only gets
-- worse as we go along, never better).
-- Holds the current status of the result. Note that once a value of
-- Known_Incompatible is set, it is sticky and does not get changed
-- to Unknown (the value in Result only gets worse as we go along,
-- never better).
procedure Check_Offset (Offs : Uint);
-- Called when Expr is a selected or indexed component with Offs set
-- to resp Component_First_Bit or Component_Size. Checks that if the
-- offset is specified it is compatible with the object alignment
-- requirements. The value in Result is modified accordingly.
Offs : Uint := No_Uint;
-- Set to a factor of the offset from the base object when Expr is a
-- selected or indexed component, based on Component_Bit_Offset and
-- Component_Size respectively. A negative value is used to represent
-- a value which is not known at compile time.
procedure Check_Prefix;
-- Checks the prefix recursively in the case where the expression
......@@ -3849,33 +3877,6 @@ package body Sem_Util is
-- compatible, or known incompatible), then set Result to R.
------------------
-- Check_Offset --
------------------
procedure Check_Offset (Offs : Uint) is
begin
-- Unspecified or zero offset is always OK
if Offs = No_Uint or else Offs = Uint_0 then
null;
-- If we do not know required alignment, any non-zero offset is
-- a potential problem (but certainly may be OK, so result is
-- unknown).
elsif Unknown_Alignment (Obj) then
Set_Result (Unknown);
-- If we know the required alignment, see if offset is compatible
else
if Offs mod (System_Storage_Unit * Alignment (Obj)) /= 0 then
Set_Result (Known_Incompatible);
end if;
end if;
end Check_Offset;
------------------
-- Check_Prefix --
------------------
......@@ -3940,33 +3941,55 @@ package body Sem_Util is
Set_Result (Unknown);
end if;
-- Check possible bad component offset and check prefix
-- Check prefix and component offset
Check_Offset
(Component_Bit_Offset (Entity (Selector_Name (Expr))));
Check_Prefix;
Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
-- If Expr is an indexed component, we must make sure there is no
-- potentially troublesome Component_Size clause and that the array
-- is not bit-packed.
elsif Nkind (Expr) = N_Indexed_Component then
declare
Typ : constant Entity_Id := Etype (Prefix (Expr));
Ind : constant Node_Id := First_Index (Typ);
begin
-- Bit packed array always generates unknown alignment
-- Bit packed array always generates unknown alignment
if Is_Bit_Packed_Array (Typ) then
Set_Result (Unknown);
end if;
if Is_Bit_Packed_Array (Etype (Prefix (Expr))) then
Set_Result (Unknown);
end if;
-- Check prefix and component offset
-- Check possible bad component size and check prefix
Check_Prefix;
Offs := Component_Size (Typ);
Check_Offset (Component_Size (Etype (Prefix (Expr))));
Check_Prefix;
-- Small optimization: compute the full offset when possible
if Offs /= No_Uint
and then Offs > Uint_0
and then Present (Ind)
and then Nkind (Ind) = N_Range
and then Compile_Time_Known_Value (Low_Bound (Ind))
and then Compile_Time_Known_Value (First (Expressions (Expr)))
then
Offs := Offs * (Expr_Value (First (Expressions (Expr)))
- Expr_Value (Low_Bound ((Ind))));
end if;
end;
end if;
-- If we have a null offset, the result is entirely determined by
-- the base object and has already been computed recursively.
if Offs = Uint_0 then
null;
-- Case where we know the alignment of the object
if Known_Alignment (Obj) then
elsif Known_Alignment (Obj) then
declare
ObjA : constant Uint := Alignment (Obj);
ExpA : Uint := No_Uint;
......@@ -3981,9 +4004,16 @@ package body Sem_Util is
-- Alignment of Obj is greater than 1, so we need to check
else
-- See if Expr is an object with known alignment
-- If we have an offset, see if it is compatible
if Is_Entity_Name (Expr)
if Offs /= No_Uint and Offs > Uint_0 then
if Offs mod (System_Storage_Unit * ObjA) /= 0 then
Set_Result (Known_Incompatible);
end if;
-- See if Expr is an object with known alignment
elsif Is_Entity_Name (Expr)
and then Known_Alignment (Entity (Expr))
then
ExpA := Alignment (Entity (Expr));
......@@ -3995,26 +4025,29 @@ package body Sem_Util is
elsif Known_Alignment (Etype (Expr)) then
ExpA := Alignment (Etype (Expr));
-- Otherwise the alignment is unknown
else
Set_Result (Default);
end if;
-- If we got an alignment, see if it is acceptable
if ExpA /= No_Uint then
if ExpA < ObjA then
Set_Result (Known_Incompatible);
end if;
if ExpA /= No_Uint and then ExpA < ObjA then
Set_Result (Known_Incompatible);
end if;
-- Case of Expr alignment unknown
-- If Expr is not a piece of a larger object, see if size
-- is given. If so, check that it is not too small for the
-- required alignment.
else
Set_Result (Default);
end if;
if Offs /= No_Uint then
null;
-- See if size is given. If so, check that it is not too
-- small for the required alignment.
-- See if Expr is an object with known alignment
-- See if Expr is an object with known size
if Is_Entity_Name (Expr)
elsif Is_Entity_Name (Expr)
and then Known_Static_Esize (Entity (Expr))
then
SizA := Esize (Entity (Expr));
......@@ -4038,6 +4071,13 @@ package body Sem_Util is
end if;
end;
-- If we do not know required alignment, any non-zero offset is
-- a potential problem (but certainly may be OK, so result is
-- unknown).
elsif Offs /= No_Uint then
Set_Result (Unknown);
-- If we can't find the result by direct comparison of alignment
-- values, then there is still one case that we can determine known
-- result, and that is when we can determine that the types are the
......
gcc/ada/sem_util.ads
......@@ -320,12 +320,16 @@ package Sem_Util is
-- denotes when analyzed. Subsequent uses of this id on a different
-- type denote the discriminant at the same position in this new type.
function Find_Overlaid_Object (N : Node_Id) return Entity_Id;
-- The node N should be an address representation clause. This function
-- checks if the target expression is the address of some stand alone
-- object (variable or constant), and if so, returns its entity. If N is
-- not an address representation clause, or if it is not possible to
-- determine that the address is of this form, then Empty is returned.
procedure Find_Overlaid_Entity
(N : Node_Id;
Ent : out Entity_Id;
Off : out Boolean);
-- The node N should be an address representation clause. Determines if
-- the target expression is the address of an entity with an optional
-- offset. If so, set Ent to the entity and, if there is an offset, set
-- Off to True, otherwise to False. If N is not an address representation
-- clause, or if it is not possible to determine that the address is of
-- this form, then set Ent to Empty.
function Find_Parameter_Type (Param : Node_Id) return Entity_Id;
-- Return the type of formal parameter Param as determined by its
......
gcc/testsuite/ChangeLog
2009-07-11 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/specs/addr1.ads: New test.
2009-07-11 Jan Hubicka <jh@suse.cz>
PR middle-end/48388
......
gcc/testsuite/gnat.dg/specs/addr1.ads 0 → 100644
-- { dg-do compile }
with Interfaces; use Interfaces;
package Addr1 is
type Arr is array (Integer range <>) of Unsigned_16;
type Rec1 is record
I1, I2: Integer;
end record;
type Rec2 is record
I1, I2: Integer;
end record;
for Rec2'Size use 64;
A: Arr (1 .. 12);
Obj1: Rec1;
for Obj1'Address use A'Address; -- { dg-bogus "alignment" }
Obj2: Rec2;
for Obj2'Address use A'Address; -- { dg-bogus "alignment" }
Obj3: Rec1;
for Obj3'Address use A(1)'Address; -- { dg-bogus "alignment" }
Obj4: Rec1;
for Obj4'Address use A(2)'Address; -- { dg-warning "(alignment|erroneous)" }
Obj5: Rec1;
for Obj5'Address use A(3)'Address; -- { dg-bogus "alignment" }
end Addr1;
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