-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id);
-- This routine is called after setting the Esize of type entity Typ.
- -- The purpose is to deal with the situation where an aligment has been
+ -- The purpose is to deal with the situation where an alignment has been
-- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown.
procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
-- Given two entities for record components or discriminants, checks
- -- if they hav overlapping component clauses and issues errors if so.
+ -- if they have overlapping component clauses and issues errors if so.
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- 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;
-- call to Validate_Unchecked_Conversions does the actual error
-- checking and posting of warnings. The reason for this delayed
-- processing is to take advantage of back-annotations of size and
- -- alignment values peformed by the back end.
+ -- alignment values performed by the back end.
+
+ -- Note: the reason we store a Source_Ptr value instead of a Node_Id
+ -- is that by the time Validate_Unchecked_Conversions is called, Sprint
+ -- will already have modified all Sloc values if the -gnatD option is set.
type UC_Entry is record
- Enode : Node_Id; -- node used for posting warnings
- Source : Entity_Id; -- source type for unchecked conversion
- Target : Entity_Id; -- target type for unchecked conversion
+ Eloc : Source_Ptr; -- node used for posting warnings
+ Source : Entity_Id; -- source type for unchecked conversion
+ Target : Entity_Id; -- target type for unchecked conversion
end record;
package Unchecked_Conversions is new Table.Table (
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 (
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 --
-----------------------------------------
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
declare
- CC : constant Node_Id := Component_Clause (Comp);
- Fbit : constant Uint := Static_Integer (First_Bit (CC));
+ CC : constant Node_Id := Component_Clause (Comp);
begin
if Present (CC) then
+ declare
+ Fbit : constant Uint := Static_Integer (First_Bit (CC));
- -- Case of component with size > max machine scalar
+ begin
+ -- Case of component with size > max machine scalar
- if Esize (Comp) > Max_Machine_Scalar_Size then
+ if Esize (Comp) > Max_Machine_Scalar_Size then
- -- Must begin on byte boundary
+ -- Must begin on byte boundary
- if Fbit mod SSU /= 0 then
- Error_Msg_N
- ("illegal first bit value for reverse bit order",
- First_Bit (CC));
- Error_Msg_Uint_1 := SSU;
- Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
-
- Error_Msg_N
- ("\must be a multiple of ^ if size greater than ^",
- First_Bit (CC));
+ if Fbit mod SSU /= 0 then
+ Error_Msg_N
+ ("illegal first bit value for reverse bit order",
+ First_Bit (CC));
+ Error_Msg_Uint_1 := SSU;
+ Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
- -- Must end on byte boundary
+ Error_Msg_N
+ ("\must be a multiple of ^ if size greater than ^",
+ First_Bit (CC));
- elsif Esize (Comp) mod SSU /= 0 then
- Error_Msg_N
- ("illegal last bit value for reverse bit order",
- Last_Bit (CC));
- Error_Msg_Uint_1 := SSU;
- Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
+ -- Must end on byte boundary
- Error_Msg_N
- ("\must be a multiple of ^ if size greater than ^",
- Last_Bit (CC));
+ elsif Esize (Comp) mod SSU /= 0 then
+ Error_Msg_N
+ ("illegal last bit value for reverse bit order",
+ Last_Bit (CC));
+ Error_Msg_Uint_1 := SSU;
+ Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
- -- OK, give warning if enabled
+ Error_Msg_N
+ ("\must be a multiple of ^ if size greater than ^",
+ Last_Bit (CC));
- elsif Warn_On_Reverse_Bit_Order then
- Error_Msg_N
- ("multi-byte field specified with non-standard"
- & " Bit_Order?", CC);
+ -- OK, give warning if enabled
- if Bytes_Big_Endian then
- Error_Msg_N
- ("\bytes are not reversed "
- & "(component is big-endian)?", CC);
- else
+ elsif Warn_On_Reverse_Bit_Order then
Error_Msg_N
- ("\bytes are not reversed "
- & "(component is little-endian)?", CC);
+ ("multi-byte field specified with non-standard"
+ & " Bit_Order?", CC);
+
+ if Bytes_Big_Endian then
+ Error_Msg_N
+ ("\bytes are not reversed "
+ & "(component is big-endian)?", CC);
+ else
+ Error_Msg_N
+ ("\bytes are not reversed "
+ & "(component is little-endian)?", CC);
+ end if;
end if;
- end if;
- -- Case where size is not greater than max machine scalar.
- -- For now, we just count these.
+ -- Case where size is not greater than max machine
+ -- scalar. For now, we just count these.
- else
- Num_CC := Num_CC + 1;
- end if;
+ else
+ Num_CC := Num_CC + 1;
+ end if;
+ end;
end if;
end;
declare
Comps : array (0 .. Num_CC) of Entity_Id;
- -- Array to collect component and discrimninant entities. The data
+ -- Array to collect component and discriminant entities. The data
-- starts at index 1, the 0'th entry is for the sort routine.
function CP_Lt (Op1, Op2 : Natural) return Boolean;
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
- -- The general rule is that the first bit is is obtained by
+ -- The general rule is that the first bit is obtained by
-- subtracting the old ending bit from machine scalar size - 1.
for C in Start .. Stop loop
if Warn_On_Reverse_Bit_Order then
Error_Msg_Uint_1 := MSS;
Error_Msg_N
- ("?reverse bit order in machine " &
- "scalar of length^", First_Bit (CC));
+ ("info: reverse bit order in machine " &
+ "scalar of length^?", First_Bit (CC));
Error_Msg_Uint_1 := NFB;
Error_Msg_Uint_2 := NLB;
if Bytes_Big_Endian then
Error_Msg_NE
- ("?\big-endian range for component & is ^ .. ^",
+ ("?\info: big-endian range for "
+ & "component & is ^ .. ^",
First_Bit (CC), Comp);
else
Error_Msg_NE
- ("?\little-endian range for component & is ^ .. ^",
+ ("?\info: little-endian range "
+ & "for component & is ^ .. ^",
First_Bit (CC), Comp);
end if;
end if;
-- Start of processing for Analyze_Attribute_Definition_Clause
begin
+ -- Process Ignore_Rep_Clauses option
+
if Ignore_Rep_Clauses then
- Rewrite (N, Make_Null_Statement (Sloc (N)));
- return;
+ case Id is
+
+ -- The following should be ignored. They do not affect legality
+ -- and may be target dependent. The basic idea of -gnatI is to
+ -- ignore any rep clauses that may be target dependent but do not
+ -- affect legality (except possibly to be rejected because they
+ -- are incompatible with the compilation target).
+
+ when Attribute_Alignment |
+ Attribute_Bit_Order |
+ Attribute_Component_Size |
+ Attribute_Machine_Radix |
+ Attribute_Object_Size |
+ Attribute_Size |
+ Attribute_Small |
+ Attribute_Stream_Size |
+ Attribute_Value_Size =>
+
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ return;
+
+ -- The following should not be ignored, because in the first place
+ -- they are reasonably portable, and should not cause problems in
+ -- compiling code from another target, and also they do affect
+ -- legality, e.g. failing to provide a stream attribute for a
+ -- type may make a program illegal.
+
+ when Attribute_External_Tag |
+ Attribute_Input |
+ Attribute_Output |
+ Attribute_Read |
+ Attribute_Storage_Pool |
+ Attribute_Storage_Size |
+ Attribute_Write =>
+ null;
+
+ -- Other cases are errors, which will be caught below
+
+ when others =>
+ null;
+ end case;
end if;
Analyze (Nam);
Analyze_And_Resolve (Expr, RTE (RE_Address));
+ -- Even when ignoring rep clauses we need to indicate that the
+ -- entity has an address clause and thus it is legal to declare
+ -- it imported.
+
+ if Ignore_Rep_Clauses then
+ if Ekind (U_Ent) = E_Variable
+ or else Ekind (U_Ent) = E_Constant
+ then
+ Record_Rep_Item (U_Ent, N);
+ end if;
+
+ return;
+ end if;
+
if Present (Address_Clause (U_Ent)) then
Error_Msg_N ("address already given for &", Nam);
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
+ -- Exported variables cannot have an address clause, because
+ -- this cancels the effect of the pragma Export.
if Is_Exported (U_Ent) then
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);
Reason => PE_Overlaid_Controlled_Object));
return;
- elsif Present (Aent)
+ elsif Present (O_Ent)
and then Ekind (U_Ent) = E_Constant
- and then Ekind (Aent) /= E_Constant
+ and then not Is_Constant_Object (O_Ent)
then
Error_Msg_N ("constant overlays a variable?", Expr);
-- 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
Set_Has_Delayed_Freeze (U_Ent);
+ -- If an initialization call has been generated for this
+ -- object, it needs to be deferred to after the freeze node
+ -- we have just now added, otherwise GIGI will see a
+ -- reference to the variable (as actual to the IP call)
+ -- before its definition.
+
+ declare
+ Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N);
+ begin
+ if Present (Init_Call) then
+ Remove (Init_Call);
+ Append_Freeze_Action (U_Ent, Init_Call);
+ end if;
+ end;
+
if Is_Exported (U_Ent) then
Error_Msg_N
("& cannot be exported if an address clause is given",
-- the variable, it is somewhere else.
Kill_Size_Check_Code (U_Ent);
- end;
- -- If the address clause is of the form:
+ -- If the address clause is of the form:
- -- for Y'Address use X'Address
+ -- for Y'Address use X'Address
- -- or
+ -- or
- -- Const : constant Address := X'Address;
- -- ...
- -- for Y'Address use Const;
+ -- 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. 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.
-
- if Address_Clause_Overlay_Warnings
- and then Comes_From_Source (N)
- then
- declare
- Ent_X : Entity_Id := Empty;
- Ent_Y : Entity_Id := Empty;
-
- 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
-- Alignment attribute definition clause
- when Attribute_Alignment => Alignment_Block : declare
+ when Attribute_Alignment => Alignment : declare
Align : constant Uint := Get_Alignment_Value (Expr);
begin
elsif Align /= No_Uint then
Set_Has_Alignment_Clause (U_Ent);
Set_Alignment (U_Ent, Align);
+
+ -- For an array type, U_Ent is the first subtype. In that case,
+ -- also set the alignment of the anonymous base type so that
+ -- other subtypes (such as the itypes for aggregates of the
+ -- type) also receive the expected alignment.
+
+ if Is_Array_Type (U_Ent) then
+ Set_Alignment (Base_Type (U_Ent), Align);
+ end if;
end if;
- end Alignment_Block;
+ end Alignment;
---------------
-- Bit_Order --
Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
Set_Component_Type (Btype, New_Ctyp);
+
+ if Warn_On_Biased_Representation then
+ Error_Msg_N
+ ("?component size clause forces biased "
+ & "representation", N);
+ end if;
end if;
Set_Component_Size (Btype, Csize);
if VM_Target = No_VM then
Set_Has_External_Tag_Rep_Clause (U_Ent);
- elsif not Inspector_Mode then
+ else
Error_Msg_Name_1 := Attr;
Error_Msg_N
("% attribute unsupported in this configuration", Nam);
or else Has_Small_Clause (U_Ent)
then
Check_Size (Expr, Etyp, Size, Biased);
- Set_Has_Biased_Representation (U_Ent, Biased);
+ Set_Has_Biased_Representation (U_Ent, Biased);
+
+ if Biased and Warn_On_Biased_Representation then
+ Error_Msg_N
+ ("?size clause forces biased representation", N);
+ end if;
end if;
-- For types set RM_Size and Esize if possible
Analyze_And_Resolve
(Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+ if not Denotes_Variable (Expr) then
+ Error_Msg_N ("storage pool must be a variable", Expr);
+ return;
+ end if;
+
if Nkind (Expr) = N_Type_Conversion then
T := Etype (Expression (Expr));
else
-- The Stack_Bounded_Pool is used internally for implementing
-- access types with a Storage_Size. Since it only work
-- properly when used on one specific type, we need to check
- -- that it is not highjacked improperly:
+ -- that it is not hijacked improperly:
-- type T is access Integer;
-- for T'Storage_Size use n;
-- type Q is access Float;
if Is_Elementary_Type (U_Ent) then
Check_Size (Expr, U_Ent, Size, Biased);
Set_Has_Biased_Representation (U_Ent, Biased);
+
+ if Biased and Warn_On_Biased_Representation then
+ Error_Msg_N
+ ("?value size clause forces biased representation", N);
+ end if;
end if;
Set_RM_Size (U_Ent, Size);
Analyze (Expression (N));
end Analyze_Free_Statement;
+ ---------------------------
+ -- Analyze_Freeze_Entity --
+ ---------------------------
+
+ procedure Analyze_Freeze_Entity (N : Node_Id) is
+ E : constant Entity_Id := Entity (N);
+
+ begin
+ -- For tagged types covering interfaces add internal entities that link
+ -- the primitives of the interfaces with the primitives that cover them.
+
+ -- Note: These entities were originally generated only when generating
+ -- code because their main purpose was to provide support to initialize
+ -- the secondary dispatch tables. They are now generated also when
+ -- compiling with no code generation to provide ASIS the relationship
+ -- between interface primitives and tagged type primitives.
+
+ if Ada_Version >= Ada_05
+ and then Ekind (E) = E_Record_Type
+ and then Is_Tagged_Type (E)
+ and then not Is_Interface (E)
+ and then Has_Interfaces (E)
+ then
+ Add_Internal_Interface_Entities (E);
+ end if;
+ end Analyze_Freeze_Entity;
+
------------------------------------------
-- Analyze_Record_Representation_Clause --
------------------------------------------
Hbit : Uint := Uint_0;
Comp : Entity_Id;
Ocomp : Entity_Id;
+ Pcomp : Entity_Id;
Biased : Boolean;
Max_Bit_So_Far : Uint;
-- are monotonically increasing, then we can skip the circuit for
-- checking for overlap, since no overlap is possible.
+ Tagged_Parent : Entity_Id := Empty;
+ -- This is set in the case of a derived tagged type for which we have
+ -- Is_Fully_Repped_Tagged_Type True (indicating that all components are
+ -- positioned by record representation clauses). In this case we must
+ -- check for overlap between components of this tagged type, and the
+ -- components of its parent. Tagged_Parent will point to this parent
+ -- type. For all other cases Tagged_Parent is left set to Empty.
+
+ Parent_Last_Bit : Uint;
+ -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
+ -- last bit position for any field in the parent type. We only need to
+ -- check overlap for fields starting below this point.
+
Overlap_Check_Required : Boolean;
-- Used to keep track of whether or not an overlap check is required
end loop;
end if;
+ -- See if we have a fully repped derived tagged type
+
+ declare
+ PS : constant Entity_Id := Parent_Subtype (Rectype);
+
+ begin
+ if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
+ Tagged_Parent := PS;
+
+ -- Find maximum bit of any component of the parent type
+
+ Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
+ Pcomp := First_Entity (Tagged_Parent);
+ while Present (Pcomp) loop
+ if Ekind (Pcomp) = E_Discriminant
+ or else
+ Ekind (Pcomp) = E_Component
+ then
+ if Component_Bit_Offset (Pcomp) /= No_Uint
+ and then Known_Static_Esize (Pcomp)
+ then
+ Parent_Last_Bit :=
+ UI_Max
+ (Parent_Last_Bit,
+ Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
+ end if;
+
+ Next_Entity (Pcomp);
+ end if;
+ end loop;
+ end if;
+ end;
+
-- All done if no component clauses
CC := First (Component_Clauses (N));
Set_Normalized_Position_Max (Fent, Uint_0);
Init_Esize (Fent, System_Address_Size);
- Set_Component_Clause (Fent,
+ Set_Component_Clause (Fent,
Make_Component_Clause (Loc,
Component_Name =>
Make_Identifier (Loc,
elsif Present (Component_Clause (Comp)) then
- -- Diagose duplicate rep clause, or check consistency
+ -- Diagnose duplicate rep clause, or check consistency
-- if this is an inherited component. In a double fault,
-- there may be a duplicate inconsistent clause for an
-- inherited component.
end;
end if;
+ -- Normal case where this is the first component clause we
+ -- have seen for this entity, so set it up properly.
+
else
-- Make reference for field in record rep clause and set
-- appropriate entity field in the field identifier.
then
Error_Msg_NE
("component overlaps tag field of&",
- CC, Rectype);
+ Component_Name (CC), Rectype);
end if;
-- This information is also set in the corresponding
Set_Has_Biased_Representation (Comp, Biased);
+ if Biased and Warn_On_Biased_Representation then
+ Error_Msg_F
+ ("?component clause forces biased "
+ & "representation", CC);
+ end if;
+
if Present (Ocomp) then
Set_Component_Clause (Ocomp, CC);
Set_Component_Bit_Offset (Ocomp, Fbit);
Error_Msg_N ("component size is negative", CC);
end if;
end if;
+
+ -- If OK component size, check parent type overlap if
+ -- this component might overlap a parent field.
+
+ if Present (Tagged_Parent)
+ and then Fbit <= Parent_Last_Bit
+ then
+ Pcomp := First_Entity (Tagged_Parent);
+ while Present (Pcomp) loop
+ if (Ekind (Pcomp) = E_Discriminant
+ or else
+ Ekind (Pcomp) = E_Component)
+ and then not Is_Tag (Pcomp)
+ and then Chars (Pcomp) /= Name_uParent
+ then
+ Check_Component_Overlap (Comp, Pcomp);
+ end if;
+
+ Next_Entity (Pcomp);
+ end loop;
+ end if;
end if;
end if;
end if;
package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt);
+ -----------
+ -- OC_Lt --
+ -----------
+
function OC_Lt (Op1, Op2 : Natural) return Boolean is
begin
return OC_Fbit (Op1) < OC_Fbit (Op2);
end OC_Lt;
+ -------------
+ -- OC_Move --
+ -------------
+
procedure OC_Move (From : Natural; To : Natural) is
begin
OC_Fbit (To) := OC_Fbit (From);
OC_Lbit (To) := OC_Lbit (From);
end OC_Move;
+ -- Start of processing for Overlap_Check
+
begin
CC := First (Component_Clauses (N));
while Present (CC) loop
if Has_Discriminants (Defining_Identifier (Clist)) then
C2_Ent :=
First_Discriminant (Defining_Identifier (Clist));
-
while Present (C2_Ent) loop
exit when C1_Ent = C2_Ent;
Check_Component_Overlap (C1_Ent, C2_Ent);
-- For records longer than System.Storage_Unit, and for those where not
-- all components have component clauses, the back end determines the
- -- length (it may for example be appopriate to round up the size
+ -- length (it may for example be appropriate to round up the size
-- to some convenient boundary, based on alignment considerations, etc).
if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
- Error_Msg_Name_1 := Chars (Entity (Nod));
- Error_Msg_Name_2 := Chars (U_Ent);
- Error_Msg_N
- ("\% must be defined before % (RM 13.1(22))!",
- Nod);
+ Error_Msg_Node_2 := U_Ent;
+ Error_Msg_NE
+ ("\& must be defined before & (RM 13.1(22))!",
+ Nod, Entity (Nod));
end if;
elsif Nkind (Nod) = N_Selected_Component then
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
- Error_Msg_Name_1 := Chars (Ent);
- Error_Msg_Name_2 := Chars (U_Ent);
- Error_Msg_N
- ("\% must be defined before % (RM 13.1(22))!",
- Nod);
+ Error_Msg_Node_2 := U_Ent;
+ Error_Msg_NE
+ ("\& must be defined before & (RM 13.1(22))!",
+ Nod, Ent);
end if;
elsif Nkind (Original_Node (Nod)) = N_Function_Call then
Nod, U_Ent);
if Comes_From_Source (Ent) then
- Error_Msg_Name_1 := Chars (Ent);
- Error_Msg_N
- ("\reference to variable% not allowed"
- & " (RM 13.1(22))!", Nod);
+ Error_Msg_NE
+ ("\reference to variable& not allowed"
+ & " (RM 13.1(22))!", Nod, Ent);
else
Error_Msg_N
("non-static expression not allowed"
when N_Null =>
return;
- when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
+ when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
Check_Expr_Constants (Left_Opnd (Nod));
Check_Expr_Constants (Right_Opnd (Nod));
-- Fall through with Hi and Lo set. Deal with biased case
- if (Biased and then not Is_Fixed_Point_Type (T))
+ if (Biased
+ and then not Is_Fixed_Point_Type (T)
+ and then not (Is_Enumeration_Type (T)
+ and then Has_Non_Standard_Rep (T)))
or else Has_Biased_Representation (T)
then
Hi := Hi - Lo;
-- Signed case. Note that we consider types like range 1 .. -1 to be
-- signed for the purpose of computing the size, since the bounds have
- -- to be accomodated in the base type.
+ -- to be accommodated in the base type.
if Lo < 0 or else Hi < 0 then
S := 1;
("representation item must be after full type declaration", N);
return True;
- -- If the type has incompleted components, a representation clause is
+ -- If the type has incomplete components, a representation clause is
-- illegal but stream attributes and Convention pragmas are correct.
elsif Has_Private_Component (T) then
end if;
end Same_Rep;
- -- Start processing for Record_Case
+ -- Start of processing for Record_Case
begin
if Has_Discriminants (T1) then
-- For enumeration types, we must check each literal to see if the
-- representation is the same. Note that we do not permit enumeration
- -- reprsentation clauses for Character and Wide_Character, so these
+ -- representation clauses for Character and Wide_Character, so these
-- cases were already dealt with.
elsif Is_Enumeration_Type (T1) then
ACCR : Address_Clause_Check_Record
renames Address_Clause_Checks.Table (J);
+ Expr : Node_Id;
+
X_Alignment : Uint;
Y_Alignment : Uint;
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
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);
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 "
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;
if Warn_On_Unchecked_Conversion then
Unchecked_Conversions.Append
(New_Val => UC_Entry'
- (Enode => N,
+ (Eloc => Sloc (N),
Source => Source,
Target => Target));
declare
T : UC_Entry renames Unchecked_Conversions.Table (N);
- Enode : constant Node_Id := T.Enode;
- Source : constant Entity_Id := T.Source;
- Target : constant Entity_Id := T.Target;
+ Eloc : constant Source_Ptr := T.Eloc;
+ Source : constant Entity_Id := T.Source;
+ Target : constant Entity_Id := T.Target;
Source_Siz : Uint;
Target_Siz : Uint;
if Serious_Errors_Detected = 0
and then Known_Static_RM_Size (Source)
and then Known_Static_RM_Size (Target)
+
+ -- Don't do the check if warnings off for either type, note the
+ -- deliberate use of OR here instead of OR ELSE to get the flag
+ -- Warnings_Off_Used set for both types if appropriate.
+
+ and then not (Has_Warnings_Off (Source)
+ or
+ Has_Warnings_Off (Target))
then
Source_Siz := RM_Size (Source);
Target_Siz := RM_Size (Target);
if Source_Siz /= Target_Siz then
- Error_Msg_N
+ Error_Msg
("?types for unchecked conversion have different sizes!",
- Enode);
+ Eloc);
if All_Errors_Mode then
Error_Msg_Name_1 := Chars (Source);
Error_Msg_Uint_1 := Source_Siz;
Error_Msg_Name_2 := Chars (Target);
Error_Msg_Uint_2 := Target_Siz;
- Error_Msg_N
- ("\size of % is ^, size of % is ^?", Enode);
+ Error_Msg ("\size of % is ^, size of % is ^?", Eloc);
Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
and then Is_Discrete_Type (Target)
then
if Source_Siz > Target_Siz then
- Error_Msg_N
+ Error_Msg
("\?^ high order bits of source will be ignored!",
- Enode);
+ Eloc);
elsif Is_Unsigned_Type (Source) then
- Error_Msg_N
+ Error_Msg
("\?source will be extended with ^ high order " &
- "zero bits?!", Enode);
+ "zero bits?!", Eloc);
else
- Error_Msg_N
+ Error_Msg
("\?source will be extended with ^ high order " &
"sign bits!",
- Enode);
+ Eloc);
end if;
elsif Source_Siz < Target_Siz then
if Is_Discrete_Type (Target) then
if Bytes_Big_Endian then
- Error_Msg_N
+ Error_Msg
("\?target value will include ^ undefined " &
"low order bits!",
- Enode);
+ Eloc);
else
- Error_Msg_N
+ Error_Msg
("\?target value will include ^ undefined " &
"high order bits!",
- Enode);
+ Eloc);
end if;
else
- Error_Msg_N
+ Error_Msg
("\?^ trailing bits of target value will be " &
- "undefined!", Enode);
+ "undefined!", Eloc);
end if;
else pragma Assert (Source_Siz > Target_Siz);
- Error_Msg_N
+ Error_Msg
("\?^ trailing bits of source will be ignored!",
- Enode);
+ Eloc);
end if;
end if;
end if;
begin
if Source_Align < Target_Align
and then not Is_Tagged_Type (D_Source)
+
+ -- Suppress warning if warnings suppressed on either
+ -- type or either designated type. Note the use of
+ -- OR here instead of OR ELSE. That is intentional,
+ -- we would like to set flag Warnings_Off_Used in
+ -- all types for which warnings are suppressed.
+
+ and then not (Has_Warnings_Off (D_Source)
+ or
+ Has_Warnings_Off (D_Target)
+ or
+ Has_Warnings_Off (Source)
+ or
+ Has_Warnings_Off (Target))
then
Error_Msg_Uint_1 := Target_Align;
Error_Msg_Uint_2 := Source_Align;
+ Error_Msg_Node_1 := D_Target;
Error_Msg_Node_2 := D_Source;
- Error_Msg_NE
+ Error_Msg
("?alignment of & (^) is stricter than " &
- "alignment of & (^)!", Enode, D_Target);
-
- if All_Errors_Mode then
- Error_Msg_N
- ("\?resulting access value may have invalid " &
- "alignment!", Enode);
- end if;
+ "alignment of & (^)!", Eloc);
+ Error_Msg
+ ("\?resulting access value may have invalid " &
+ "alignment!", Eloc);
end if;
end;
end if;
OSDN Git Service
