Commit f4cd2542 by Eric Botcazou Committed by Eric Botcazou

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
2009-07-11 Eric Botcazou <ebotcazou@adacore.com> 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/ada-tree.h: Minor reorganization.
* gcc-interface/misc.c (gnat_print_decl): Minor tweaks. * gcc-interface/misc.c (gnat_print_decl): Minor tweaks.
(gnat_print_type): Likewise. (gnat_print_type): Likewise.
......
...@@ -532,16 +532,11 @@ package body Checks is ...@@ -532,16 +532,11 @@ package body Checks is
-- 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.
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; procedure Compile_Time_Bad_Alignment;
-- Post error warnings when alignment is known to be incompatible. Note -- 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 -- 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 -- 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 -- underaligned address turns out to be OK after all.
-- is suppressed if we already complained about the size.
-------------------------------- --------------------------------
-- Compile_Time_Bad_Alignment -- -- Compile_Time_Bad_Alignment --
...@@ -549,9 +544,7 @@ package body Checks is ...@@ -549,9 +544,7 @@ package body Checks is
procedure Compile_Time_Bad_Alignment is procedure Compile_Time_Bad_Alignment is
begin begin
if not Size_Warning_Output if Address_Clause_Overlay_Warnings then
and then Address_Clause_Overlay_Warnings
then
Error_Msg_FE Error_Msg_FE
("?specified address for& may be inconsistent with alignment ", ("?specified address for& may be inconsistent with alignment ",
Aexp, E); Aexp, E);
...@@ -565,7 +558,24 @@ package body Checks is ...@@ -565,7 +558,24 @@ package body Checks is
-- Start of processing for Apply_Address_Clause_Check -- Start of processing for Apply_Address_Clause_Check
begin 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); Expr := Expression (AC);
...@@ -603,69 +613,7 @@ package body Checks is ...@@ -603,69 +613,7 @@ package body Checks is
end if; end if;
end loop; end loop;
-- Output a warning if we have the situation of -- See if we know that Expr has a bad alignment at compile time
-- 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
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))
...@@ -690,20 +638,14 @@ package body Checks is ...@@ -690,20 +638,14 @@ package body Checks is
-- If the expression has the form X'Address, then we can find out if -- 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. -- 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 elsif Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address and then Attribute_Name (Expr) = Name_Address
and then Has_Compatible_Alignment (E, Prefix (Expr)) = Known_Compatible
then then
declare
AR : constant Alignment_Result :=
Has_Compatible_Alignment (E, Prefix (Expr));
begin
if AR = Known_Compatible then
return; return;
elsif AR = Known_Incompatible then
Compile_Time_Bad_Alignment;
end if;
end;
end if; end if;
-- Here we do not know if the value is acceptable. Stricly we don't have -- Here we do not know if the value is acceptable. Stricly we don't have
......
...@@ -905,6 +905,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) ...@@ -905,6 +905,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
mark_visited (&gnu_decl); mark_visited (&gnu_decl);
save_gnu_tree (gnat_entity, gnu_decl, true); save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true; saved = true;
annotate_object (gnat_entity, gnu_type, NULL_TREE,
false);
break; break;
} }
...@@ -1382,32 +1384,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) ...@@ -1382,32 +1384,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& Exception_Mechanism != Back_End_Exceptions) && Exception_Mechanism != Back_End_Exceptions)
TREE_ADDRESSABLE (gnu_decl) = 1; TREE_ADDRESSABLE (gnu_decl) = 1;
gnu_type = TREE_TYPE (gnu_decl); /* Back-annotate Esize and Alignment of the object if not already
known. Note that we pick the values of the type, not those of
/* Back-annotate Alignment and Esize of the object if not already the object, to shield ourselves from low-level platform-dependent
known, except for when the object is actually a pointer to the adjustments like alignment promotion. This is both consistent with
real object, since alignment and size of a pointer don't have all the treatment above, where alignment and size are set on the
anything to do with those of the designated object. Note that type of the object and not on the object directly, and makes it
we pick the values of the type, not those of the object, to possible to support all confirming representation clauses. */
shield ourselves from low-level platform-dependent adjustments annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
like alignment promotion. This is both consistent with all the used_by_ref);
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));
}
} }
break; break;
...@@ -7223,6 +7208,39 @@ annotate_value (tree gnu_size) ...@@ -7223,6 +7208,39 @@ annotate_value (tree gnu_size)
return ret; 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 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
GCC type, set Component_Bit_Offset and Esize to the position and size GCC type, set Component_Bit_Offset and Esize to the position and size
used by Gigi. */ used by Gigi. */
......
...@@ -135,6 +135,13 @@ extern tree maybe_pad_type (tree type, tree size, unsigned int align, ...@@ -135,6 +135,13 @@ extern tree maybe_pad_type (tree type, tree size, unsigned int align,
the value passed against the list of choices. */ the value passed against the list of choices. */
extern tree choices_to_gnu (tree operand, Node_Id 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 /* 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 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 with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
......
...@@ -2328,13 +2328,18 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) ...@@ -2328,13 +2328,18 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
end_subprog_body (gnu_result, false); end_subprog_body (gnu_result, false);
/* Disconnect the trees for parameters that we made variables for from the /* Finally annotate the parameters and disconnect the trees for parameters
GNAT entities since these are unusable after we end the function. */ that we have turned into variables since they are now unusable. */
for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
Present (gnat_param); Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param)) gnat_param = Next_Formal_With_Extras (gnat_param))
if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL) {
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); save_gnu_tree (gnat_param, NULL_TREE, false);
}
if (DECL_FUNCTION_STUB (gnu_subprog_decl)) if (DECL_FUNCTION_STUB (gnu_subprog_decl))
build_function_stub (gnu_subprog_decl, gnat_subprog_id); build_function_stub (gnu_subprog_decl, gnat_subprog_id);
......
...@@ -87,9 +87,6 @@ package body Sem_Ch13 is ...@@ -87,9 +87,6 @@ package body Sem_Ch13 is
-- Attributes that do not specify a representation characteristic are -- Attributes that do not specify a representation characteristic are
-- operational attributes. -- 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 procedure New_Stream_Subprogram
(N : Node_Id; (N : Node_Id;
Ent : Entity_Id; Ent : Entity_Id;
...@@ -164,6 +161,9 @@ package body Sem_Ch13 is ...@@ -164,6 +161,9 @@ package body Sem_Ch13 is
Y : Entity_Id; Y : Entity_Id;
-- The entity of the object being overlaid -- The entity of the object being overlaid
Off : Boolean;
-- Whether the address is offseted within Y
end record; end record;
package Address_Clause_Checks is new Table.Table ( package Address_Clause_Checks is new Table.Table (
...@@ -174,33 +174,6 @@ package body Sem_Ch13 is ...@@ -174,33 +174,6 @@ package body Sem_Ch13 is
Table_Increment => 200, Table_Increment => 200,
Table_Name => "Address_Clause_Checks"); 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 -- -- Adjust_Record_For_Reverse_Bit_Order --
----------------------------------------- -----------------------------------------
...@@ -907,10 +880,11 @@ package body Sem_Ch13 is ...@@ -907,10 +880,11 @@ package body Sem_Ch13 is
then then
declare declare
Expr : constant Node_Id := Expression (N); Expr : constant Node_Id := Expression (N);
Aent : constant Entity_Id := Address_Aliased_Entity (Expr); O_Ent : Entity_Id;
Ent_Y : constant Entity_Id := Find_Overlaid_Object (N); Off : Boolean;
begin begin
-- Exported variables cannot have an address clause, -- Exported variables cannot have an address clause,
-- because this cancels the effect of the pragma Export -- because this cancels the effect of the pragma Export
...@@ -918,12 +892,15 @@ package body Sem_Ch13 is ...@@ -918,12 +892,15 @@ package body Sem_Ch13 is
Error_Msg_N Error_Msg_N
("cannot export object with address clause", Nam); ("cannot export object with address clause", Nam);
return; return;
end if;
Find_Overlaid_Entity (N, O_Ent, Off);
-- Overlaying controlled objects is erroneous -- Overlaying controlled objects is erroneous
elsif Present (Aent) if Present (O_Ent)
and then (Has_Controlled_Component (Etype (Aent)) and then (Has_Controlled_Component (Etype (O_Ent))
or else Is_Controlled (Etype (Aent))) or else Is_Controlled (Etype (O_Ent)))
then then
Error_Msg_N Error_Msg_N
("?cannot overlay with controlled object", Expr); ("?cannot overlay with controlled object", Expr);
...@@ -934,9 +911,9 @@ package body Sem_Ch13 is ...@@ -934,9 +911,9 @@ package body Sem_Ch13 is
Reason => PE_Overlaid_Controlled_Object)); Reason => PE_Overlaid_Controlled_Object));
return; return;
elsif Present (Aent) elsif Present (O_Ent)
and then Ekind (U_Ent) = E_Constant and then Ekind (U_Ent) = E_Constant
and then not Is_Constant_Object (Aent) and then not Is_Constant_Object (O_Ent)
then then
Error_Msg_N ("constant overlays a variable?", Expr); Error_Msg_N ("constant overlays a variable?", Expr);
...@@ -964,10 +941,15 @@ package body Sem_Ch13 is ...@@ -964,10 +941,15 @@ package body Sem_Ch13 is
-- Here we are checking for explicit overlap of one variable -- Here we are checking for explicit overlap of one variable
-- by another, and if we find this then mark the overlapped -- by another, and if we find this then mark the overlapped
-- variable as also being volatile to prevent unwanted -- 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 if Present (O_Ent)
Set_Treat_As_Volatile (Ent_Y); and then Is_Object (O_Ent)
and then not Off
then
Set_Treat_As_Volatile (O_Ent);
end if; end if;
-- Legality checks on the address clause for initialized -- Legality checks on the address clause for initialized
...@@ -1015,7 +997,6 @@ package body Sem_Ch13 is ...@@ -1015,7 +997,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);
end;
-- If the address clause is of the form: -- If the address clause is of the form:
...@@ -1027,41 +1008,31 @@ package body Sem_Ch13 is ...@@ -1027,41 +1008,31 @@ package body Sem_Ch13 is
-- ... -- ...
-- for Y'Address use Const; -- for Y'Address use Const;
-- then we make an entry in the table for checking the size and -- then we make an entry in the table for checking the size
-- alignment of the overlaying variable. We defer this check -- and alignment of the overlaying variable. We defer this
-- till after code generation to take full advantage of the -- check till after code generation to take full advantage
-- annotation done by the back end. This entry is only made if -- of the annotation done by the back end. This entry is
-- we have not already posted a warning about size/alignment -- only made if the address clause comes from source.
-- (some warnings of this type are posted in Checks), and if
-- the address clause comes from source.
if Address_Clause_Overlay_Warnings if Address_Clause_Overlay_Warnings
and then Comes_From_Source (N) and then Comes_From_Source (N)
and then Present (O_Ent)
and then Is_Object (O_Ent)
then then
declare Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
Ent_X : Entity_Id := Empty;
Ent_Y : Entity_Id := Empty;
begin
Ent_Y := Find_Overlaid_Object (N);
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 variable overlays a constant view, and we are -- If variable overlays a constant view, and we are
-- warning on overlays, then mark the variable as -- warning on overlays, then mark the variable as
-- overlaying a constant (we will give warnings later -- overlaying a constant (we will give warnings later
-- if this variable is assigned). -- if this variable is assigned).
if Is_Constant_Object (Ent_Y) if Is_Constant_Object (O_Ent)
and then Ekind (Ent_X) = E_Variable and then Ekind (U_Ent) = E_Variable
then then
Set_Overlays_Constant (Ent_X); Set_Overlays_Constant (U_Ent);
end if; end if;
end if; end if;
end; end;
end if;
-- Not a valid entity for an address clause -- Not a valid entity for an address clause
...@@ -4255,6 +4226,8 @@ package body Sem_Ch13 is ...@@ -4255,6 +4226,8 @@ package body Sem_Ch13 is
ACCR : Address_Clause_Check_Record ACCR : Address_Clause_Check_Record
renames Address_Clause_Checks.Table (J); renames Address_Clause_Checks.Table (J);
Expr : Node_Id;
X_Alignment : Uint; X_Alignment : Uint;
Y_Alignment : Uint; Y_Alignment : Uint;
...@@ -4266,35 +4239,17 @@ package body Sem_Ch13 is ...@@ -4266,35 +4239,17 @@ package body Sem_Ch13 is
if not Address_Warning_Posted (ACCR.N) then if not Address_Warning_Posted (ACCR.N) then
-- Get alignments. Really we should always have the alignment Expr := Original_Node (Expression (ACCR.N));
-- of the objects properly back annotated, but right now the
-- back end fails to back annotate for address clauses???
if Known_Alignment (ACCR.X) then -- Get alignments
X_Alignment := Alignment (ACCR.X);
else
X_Alignment := Alignment (Etype (ACCR.X));
end if;
if Known_Alignment (ACCR.Y) then X_Alignment := Alignment (ACCR.X);
Y_Alignment := Alignment (ACCR.Y); Y_Alignment := Alignment (ACCR.Y);
else
Y_Alignment := Alignment (Etype (ACCR.Y));
end if;
-- Similarly obtain sizes -- Similarly obtain sizes
if Known_Esize (ACCR.X) then
X_Size := Esize (ACCR.X); 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); Y_Size := Esize (ACCR.Y);
else
Y_Size := Esize (Etype (ACCR.Y));
end if;
-- Check for large object overlaying smaller one -- Check for large object overlaying smaller one
...@@ -4302,8 +4257,10 @@ package body Sem_Ch13 is ...@@ -4302,8 +4257,10 @@ package body Sem_Ch13 is
and then X_Size > Uint_0 and then X_Size > Uint_0
and then X_Size > Y_Size and then X_Size > Y_Size
then then
Error_Msg_NE
("?& overlays smaller object", ACCR.N, ACCR.X);
Error_Msg_N 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_Uint_1 := X_Size;
Error_Msg_NE Error_Msg_NE
("\?size of & is ^", ACCR.N, ACCR.X); ("\?size of & is ^", ACCR.N, ACCR.X);
...@@ -4311,16 +4268,23 @@ package body Sem_Ch13 is ...@@ -4311,16 +4268,23 @@ package body Sem_Ch13 is
Error_Msg_NE Error_Msg_NE
("\?size of & is ^", ACCR.N, ACCR.Y); ("\?size of & is ^", ACCR.N, ACCR.Y);
-- Check for inadequate alignment. Again the defensive check -- Check for inadequate alignment, both of the base object
-- on Y_Alignment should not be needed, but because of the -- and of the offset, if any.
-- failure in back end annotation, we can have an alignment
-- of 0 here???
-- Note: we do not check alignments 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 Y_Alignment /= Uint_0 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 then
Error_Msg_NE Error_Msg_NE
("?specified address for& may be inconsistent " ("?specified address for& may be inconsistent "
...@@ -4337,6 +4301,11 @@ package body Sem_Ch13 is ...@@ -4337,6 +4301,11 @@ package body Sem_Ch13 is
Error_Msg_NE Error_Msg_NE
("\?alignment of & is ^", ("\?alignment of & is ^",
ACCR.N, ACCR.Y); 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 if; end if;
end; end;
......
...@@ -2892,10 +2892,14 @@ package body Sem_Util is ...@@ -2892,10 +2892,14 @@ package body Sem_Util is
end Find_Corresponding_Discriminant; end Find_Corresponding_Discriminant;
-------------------------- --------------------------
-- Find_Overlaid_Object -- -- Find_Overlaid_Entity --
-------------------------- --------------------------
function Find_Overlaid_Object (N : Node_Id) return Entity_Id is procedure Find_Overlaid_Entity
(N : Node_Id;
Ent : out Entity_Id;
Off : out Boolean)
is
Expr : Node_Id; Expr : Node_Id;
begin begin
...@@ -2912,24 +2916,25 @@ package body Sem_Util is ...@@ -2912,24 +2916,25 @@ package body Sem_Util is
-- In the second case, the expr is either Y'Address, or recursively a -- In the second case, the expr is either Y'Address, or recursively a
-- constant that eventually references Y'Address. -- constant that eventually references Y'Address.
Ent := Empty;
Off := False;
if Nkind (N) = N_Attribute_Definition_Clause if Nkind (N) = N_Attribute_Definition_Clause
and then Chars (N) = Name_Address and then Chars (N) = Name_Address
then 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); Expr := Expression (N);
-- This loop checks the form of the expression for Y'Address,
-- using recursion to deal with intermediate constants.
loop loop
-- Check for Y'Address where Y is an object entity -- Check for Y'Address
if Nkind (Expr) = N_Attribute_Reference if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address and then Attribute_Name (Expr) = Name_Address
and then Is_Entity_Name (Prefix (Expr))
and then Is_Object (Entity (Prefix (Expr)))
then then
return Entity (Prefix (Expr)); Expr := Prefix (Expr);
exit;
-- Check for Const where Const is a constant entity -- Check for Const where Const is a constant entity
...@@ -2941,13 +2946,36 @@ package body Sem_Util is ...@@ -2941,13 +2946,36 @@ package body Sem_Util is
-- Anything else does not need checking -- Anything else does not need checking
else else
exit; return;
end if; end if;
end loop; end loop;
end if;
return Empty; -- This loop checks the form of the prefix for an entity,
end Find_Overlaid_Object; -- 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 -- -- Find_Parameter_Type --
...@@ -3829,16 +3857,16 @@ package body Sem_Util is ...@@ -3829,16 +3857,16 @@ package body Sem_Util is
Default : Alignment_Result) return Alignment_Result Default : Alignment_Result) return Alignment_Result
is is
Result : Alignment_Result := Known_Compatible; Result : Alignment_Result := Known_Compatible;
-- Set to result if Problem_Prefix or Problem_Offset returns True. -- Holds the current status of the result. Note that once a value of
-- Note that once a value of Known_Incompatible is set, it is sticky -- Known_Incompatible is set, it is sticky and does not get changed
-- and does not get changed to Unknown (the value in Result only gets -- to Unknown (the value in Result only gets worse as we go along,
-- worse as we go along, never better). -- never better).
procedure Check_Offset (Offs : Uint); Offs : Uint := No_Uint;
-- Called when Expr is a selected or indexed component with Offs set -- Set to a factor of the offset from the base object when Expr is a
-- to resp Component_First_Bit or Component_Size. Checks that if the -- selected or indexed component, based on Component_Bit_Offset and
-- offset is specified it is compatible with the object alignment -- Component_Size respectively. A negative value is used to represent
-- requirements. The value in Result is modified accordingly. -- a value which is not known at compile time.
procedure Check_Prefix; procedure Check_Prefix;
-- Checks the prefix recursively in the case where the expression -- Checks the prefix recursively in the case where the expression
...@@ -3849,33 +3877,6 @@ package body Sem_Util is ...@@ -3849,33 +3877,6 @@ package body Sem_Util is
-- compatible, or known incompatible), then set Result to R. -- 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 -- -- Check_Prefix --
------------------ ------------------
...@@ -3940,33 +3941,55 @@ package body Sem_Util is ...@@ -3940,33 +3941,55 @@ package body Sem_Util is
Set_Result (Unknown); Set_Result (Unknown);
end if; 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; Check_Prefix;
Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
-- If Expr is an indexed component, we must make sure there is no -- If Expr is an indexed component, we must make sure there is no
-- potentially troublesome Component_Size clause and that the array -- potentially troublesome Component_Size clause and that the array
-- is not bit-packed. -- is not bit-packed.
elsif Nkind (Expr) = N_Indexed_Component then 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 (Etype (Prefix (Expr))) then if Is_Bit_Packed_Array (Typ) then
Set_Result (Unknown); Set_Result (Unknown);
end if; end if;
-- Check possible bad component size and check prefix -- Check prefix and component offset
Check_Offset (Component_Size (Etype (Prefix (Expr))));
Check_Prefix; Check_Prefix;
Offs := Component_Size (Typ);
-- 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 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 -- Case where we know the alignment of the object
if Known_Alignment (Obj) then elsif Known_Alignment (Obj) then
declare declare
ObjA : constant Uint := Alignment (Obj); ObjA : constant Uint := Alignment (Obj);
ExpA : Uint := No_Uint; ExpA : Uint := No_Uint;
...@@ -3981,9 +4004,16 @@ package body Sem_Util is ...@@ -3981,9 +4004,16 @@ package body Sem_Util is
-- Alignment of Obj is greater than 1, so we need to check -- Alignment of Obj is greater than 1, so we need to check
else else
-- If we have an offset, see if it is compatible
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 -- See if Expr is an object with known alignment
if Is_Entity_Name (Expr) elsif Is_Entity_Name (Expr)
and then Known_Alignment (Entity (Expr)) and then Known_Alignment (Entity (Expr))
then then
ExpA := Alignment (Entity (Expr)); ExpA := Alignment (Entity (Expr));
...@@ -3995,26 +4025,29 @@ package body Sem_Util is ...@@ -3995,26 +4025,29 @@ package body Sem_Util is
elsif Known_Alignment (Etype (Expr)) then elsif Known_Alignment (Etype (Expr)) then
ExpA := Alignment (Etype (Expr)); ExpA := Alignment (Etype (Expr));
-- Otherwise the alignment is unknown
else
Set_Result (Default);
end if; end if;
-- If we got an alignment, see if it is acceptable -- If we got an alignment, see if it is acceptable
if ExpA /= No_Uint then if ExpA /= No_Uint and then ExpA < ObjA then
if ExpA < ObjA then
Set_Result (Known_Incompatible); Set_Result (Known_Incompatible);
end if; 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 if Offs /= No_Uint then
Set_Result (Default); null;
end if;
-- See if size is given. If so, check that it is not too -- See if Expr is an object with known size
-- small for the required alignment.
-- See if Expr is an object with known alignment
if Is_Entity_Name (Expr) elsif Is_Entity_Name (Expr)
and then Known_Static_Esize (Entity (Expr)) and then Known_Static_Esize (Entity (Expr))
then then
SizA := Esize (Entity (Expr)); SizA := Esize (Entity (Expr));
...@@ -4038,6 +4071,13 @@ package body Sem_Util is ...@@ -4038,6 +4071,13 @@ package body Sem_Util is
end if; end if;
end; 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 -- If we can't find the result by direct comparison of alignment
-- values, then there is still one case that we can determine known -- 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 -- result, and that is when we can determine that the types are the
......
...@@ -320,12 +320,16 @@ package Sem_Util is ...@@ -320,12 +320,16 @@ package Sem_Util is
-- denotes when analyzed. Subsequent uses of this id on a different -- denotes when analyzed. Subsequent uses of this id on a different
-- type denote the discriminant at the same position in this new type. -- type denote the discriminant at the same position in this new type.
function Find_Overlaid_Object (N : Node_Id) return Entity_Id; procedure Find_Overlaid_Entity
-- The node N should be an address representation clause. This function (N : Node_Id;
-- checks if the target expression is the address of some stand alone Ent : out Entity_Id;
-- object (variable or constant), and if so, returns its entity. If N is Off : out Boolean);
-- not an address representation clause, or if it is not possible to -- The node N should be an address representation clause. Determines if
-- determine that the address is of this form, then Empty is returned. -- 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; function Find_Parameter_Type (Param : Node_Id) return Entity_Id;
-- Return the type of formal parameter Param as determined by its -- Return the type of formal parameter Param as determined by its
......
2009-07-11 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/specs/addr1.ads: New test.
2009-07-11 Jan Hubicka <jh@suse.cz> 2009-07-11 Jan Hubicka <jh@suse.cz>
PR middle-end/48388 PR middle-end/48388
......
-- { 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