------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- You should have received a copy of the GNU General Public License along --
+-- with this program; see file COPYING3. If not see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Disp; use Exp_Disp;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
with Layout; use Layout;
-with Lib.Xref; use Lib.Xref;
+with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
New_S : Entity_Id;
After : in out Node_Id)
is
- Body_Node : constant Node_Id := Build_Renamed_Body (Decl, New_S);
+ Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S);
+ Ent : constant Entity_Id := Defining_Entity (Decl);
+ Body_Node : Node_Id;
+ Renamed_Subp : Entity_Id;
+
begin
- Insert_After (After, Body_Node);
- Mark_Rewrite_Insertion (Body_Node);
- Analyze (Body_Node);
- After := Body_Node;
+ -- If the renamed subprogram is intrinsic, there is no need for a
+ -- wrapper body: we set the alias that will be called and expanded which
+ -- completes the declaration. This transformation is only legal if the
+ -- renamed entity has already been elaborated.
+
+ -- Note that it is legal for a renaming_as_body to rename an intrinsic
+ -- subprogram, as long as the renaming occurs before the new entity
+ -- is frozen. See RM 8.5.4 (5).
+
+ if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration
+ and then Is_Entity_Name (Name (Body_Decl))
+ then
+ Renamed_Subp := Entity (Name (Body_Decl));
+ else
+ Renamed_Subp := Empty;
+ end if;
+
+ if Present (Renamed_Subp)
+ and then Is_Intrinsic_Subprogram (Renamed_Subp)
+ and then
+ (not In_Same_Source_Unit (Renamed_Subp, Ent)
+ or else Sloc (Renamed_Subp) < Sloc (Ent))
+
+ -- We can make the renaming entity intrisic if the renamed function
+ -- has an interface name, or if it is one of the shift/rotate
+ -- operations known to the compiler.
+
+ and then (Present (Interface_Name (Renamed_Subp))
+ or else Chars (Renamed_Subp) = Name_Rotate_Left
+ or else Chars (Renamed_Subp) = Name_Rotate_Right
+ or else Chars (Renamed_Subp) = Name_Shift_Left
+ or else Chars (Renamed_Subp) = Name_Shift_Right
+ or else Chars (Renamed_Subp) = Name_Shift_Right_Arithmetic)
+ then
+ Set_Interface_Name (Ent, Interface_Name (Renamed_Subp));
+
+ if Present (Alias (Renamed_Subp)) then
+ Set_Alias (Ent, Alias (Renamed_Subp));
+ else
+ Set_Alias (Ent, Renamed_Subp);
+ end if;
+
+ Set_Is_Intrinsic_Subprogram (Ent);
+ Set_Has_Completion (Ent);
+
+ else
+ Body_Node := Build_Renamed_Body (Decl, New_S);
+ Insert_After (After, Body_Node);
+ Mark_Rewrite_Insertion (Body_Node);
+ Analyze (Body_Node);
+ After := Body_Node;
+ end if;
end Build_And_Analyze_Renamed_Body;
------------------------
New_S : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (New_S);
- -- We use for the source location of the renamed body, the location
- -- of the spec entity. It might seem more natural to use the location
- -- of the renaming declaration itself, but that would be wrong, since
- -- then the body we create would look as though it was created far
- -- too late, and this could cause problems with elaboration order
- -- analysis, particularly in connection with instantiations.
+ -- We use for the source location of the renamed body, the location of
+ -- the spec entity. It might seem more natural to use the location of
+ -- the renaming declaration itself, but that would be wrong, since then
+ -- the body we create would look as though it was created far too late,
+ -- and this could cause problems with elaboration order analysis,
+ -- particularly in connection with instantiations.
N : constant Node_Id := Unit_Declaration_Node (New_S);
Nam : constant Node_Id := Name (N);
Call_Name := New_Copy (Name (N));
end if;
- -- The original name may have been overloaded, but
- -- is fully resolved now.
+ -- Original name may have been overloaded, but is fully resolved now
Set_Is_Overloaded (Call_Name, False);
end if;
-- For simple renamings, subsequent calls can be expanded directly as
- -- called to the renamed entity. The body must be generated in any case
- -- for calls they may appear elsewhere.
+ -- calls to the renamed entity. The body must be generated in any case
+ -- for calls that may appear elsewhere.
- if (Ekind (Old_S) = E_Function
- or else Ekind (Old_S) = E_Procedure)
+ if Ekind_In (Old_S, E_Function, E_Procedure)
and then Nkind (Decl) = N_Subprogram_Declaration
then
Set_Body_To_Inline (Decl, Old_S);
Form_Type : constant Entity_Id := Etype (First_Formal (Old_S));
begin
-
-- The controlling formal may be an access parameter, or the
- -- actual may be an access value, so ajust accordingly.
+ -- actual may be an access value, so adjust accordingly.
if Is_Access_Type (Pref_Type)
and then not Is_Access_Type (Form_Type)
if Present (Formal) then
O_Formal := First_Formal (Old_S);
Param_Spec := First (Parameter_Specifications (Spec));
-
while Present (Formal) loop
if Is_Entry (Old_S) then
-
if Nkind (Parameter_Type (Param_Spec)) /=
N_Access_Definition
then
Make_Defining_Identifier (Loc, Chars => Chars (New_S)));
Param_Spec := First (Parameter_Specifications (Spec));
-
while Present (Param_Spec) loop
Set_Defining_Identifier (Param_Spec,
Make_Defining_Identifier (Loc,
if Present (Addr) then
Expr := Expression (Addr);
- -- If we have no initialization of any kind, then we don't need to
- -- place any restrictions on the address clause, because the object
- -- will be elaborated after the address clause is evaluated. This
- -- happens if the declaration has no initial expression, or the type
- -- has no implicit initialization, or the object is imported.
+ if Needs_Constant_Address (Decl, Typ) then
+ Check_Constant_Address_Clause (Expr, E);
- -- The same holds for all initialized scalar types and all access
- -- types. Packed bit arrays of size up to 64 are represented using a
- -- modular type with an initialization (to zero) and can be processed
- -- like other initialized scalar types.
+ -- Has_Delayed_Freeze was set on E when the address clause was
+ -- analyzed. Reset the flag now unless freeze actions were
+ -- attached to it in the mean time.
- -- If the type is controlled, code to attach the object to a
- -- finalization chain is generated at the point of declaration,
- -- and therefore the elaboration of the object cannot be delayed:
- -- the address expression must be a constant.
+ if No (Freeze_Node (E)) then
+ Set_Has_Delayed_Freeze (E, False);
+ end if;
+ end if;
- if (No (Expression (Decl))
- and then not Controlled_Type (Typ)
- and then
- (not Has_Non_Null_Base_Init_Proc (Typ)
- or else Is_Imported (E)))
+ -- If Rep_Clauses are to be ignored, remove address clause from
+ -- list attached to entity, because it may be illegal for gigi,
+ -- for example by breaking order of elaboration..
- or else
- (Present (Expression (Decl))
- and then Is_Scalar_Type (Typ))
+ if Ignore_Rep_Clauses then
+ declare
+ Rep : Node_Id;
- or else
- Is_Access_Type (Typ)
+ begin
+ Rep := First_Rep_Item (E);
- or else
- (Is_Bit_Packed_Array (Typ)
- and then
- Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
- then
- null;
+ if Rep = Addr then
+ Set_First_Rep_Item (E, Next_Rep_Item (Addr));
- -- Otherwise, we require the address clause to be constant because
- -- the call to the initialization procedure (or the attach code) has
- -- to happen at the point of the declaration.
+ else
+ while Present (Rep)
+ and then Next_Rep_Item (Rep) /= Addr
+ loop
+ Rep := Next_Rep_Item (Rep);
+ end loop;
+ end if;
- else
- Check_Constant_Address_Clause (Expr, E);
- Set_Has_Delayed_Freeze (E, False);
- end if;
+ if Present (Rep) then
+ Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr));
+ end if;
+ end;
+
+ Rewrite (Addr, Make_Null_Statement (Sloc (E)));
- if not Error_Posted (Expr)
- and then not Controlled_Type (Typ)
+ elsif not Error_Posted (Expr)
+ and then not Needs_Finalization (Typ)
then
Warn_Overlay (Expr, Typ, Name (Addr));
end if;
procedure Set_Small_Size (T : Entity_Id; S : Uint);
-- Sets the compile time known size (32 bits or less) in the Esize
-- field, of T checking for a size clause that was given which attempts
- -- to give a smaller size.
+ -- to give a smaller size, and also checking for an alignment clause.
function Size_Known (T : Entity_Id) return Boolean;
-- Recursive function that does all the work
if S > 32 then
return;
+ -- Don't bother if alignment clause with a value other than 1 is
+ -- present, because size may be padded up to meet back end alignment
+ -- requirements, and only the back end knows the rules!
+
+ elsif Known_Alignment (T) and then Alignment (T) /= 1 then
+ return;
+
+ -- Check for bad size clause given
+
elsif Has_Size_Clause (T) then
if RM_Size (T) < S then
Error_Msg_Uint_1 := S;
Error_Msg_NE
- ("size for & too small, minimum allowed is ^",
+ ("size for& too small, minimum allowed is ^",
Size_Clause (T), T);
elsif Unknown_Esize (T) then
if Size_Known_At_Compile_Time (T) then
return True;
+ -- Always True for scalar types. This is true even for generic formal
+ -- scalar types. We used to return False in the latter case, but the
+ -- size is known at compile time, even in the template, we just do
+ -- not know the exact size but that's not the point of this routine.
+
elsif Is_Scalar_Type (T)
or else Is_Task_Type (T)
then
- return not Is_Generic_Type (T);
+ return True;
+
+ -- Array types
elsif Is_Array_Type (T) then
+
+ -- String literals always have known size, and we can set it
+
if Ekind (T) = E_String_Literal_Subtype then
Set_Small_Size (T, Component_Size (T)
* String_Literal_Length (T));
return True;
+ -- Unconstrained types never have known at compile time size
+
elsif not Is_Constrained (T) then
return False;
elsif Error_Posted (T) then
return False;
+ -- Otherwise if component size unknown, then array size unknown
+
elsif not Size_Known (Component_Type (T)) then
return False;
end if;
return True;
end;
+ -- Access types always have known at compile time sizes
+
elsif Is_Access_Type (T) then
return True;
+ -- For non-generic private types, go to underlying type if present
+
elsif Is_Private_Type (T)
and then not Is_Generic_Type (T)
and then Present (Underlying_Type (T))
return Size_Known (Underlying_Type (T));
end if;
+ -- Record types
+
elsif Is_Record_Type (T) then
-- A class-wide type is never considered to have a known size
and then Present (Parent (T))
and then Nkind (Parent (T)) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Parent (T))) =
- N_Record_Definition
+ N_Record_Definition
and then not Null_Present (Type_Definition (Parent (T)))
and then Present (Variant_Part
(Component_List (Type_Definition (Parent (T)))))
if not Is_Constrained (T)
and then
- No (Discriminant_Default_Value
- (First_Discriminant (T)))
+ No (Discriminant_Default_Value (First_Discriminant (T)))
and then Unknown_Esize (T)
then
return False;
-- discriminant.
-- This is because gigi computes the size by doing a
- -- substituation of the appropriate discriminant value in
+ -- substitution of the appropriate discriminant value in
-- the size expression for the base type, and gigi is not
-- clever enough to evaluate the resulting expression (which
-- involves a call to rep_to_pos) at compile time.
if Is_Elementary_Type (Ctyp)
or else (Is_Array_Type (Ctyp)
- and then Present (Packed_Array_Type (Ctyp))
- and then Is_Modular_Integer_Type
- (Packed_Array_Type (Ctyp)))
+ and then Present (Packed_Array_Type (Ctyp))
+ and then Is_Modular_Integer_Type
+ (Packed_Array_Type (Ctyp)))
then
- -- If RM_Size is known and static, then we can
- -- keep accumulating the packed size.
+ -- If RM_Size is known and static, then we can keep
+ -- accumulating the packed size.
if Known_Static_RM_Size (Ctyp) then
return True;
end;
+ -- All other cases, size not known at compile time
+
else
return False;
end if;
-- Do not attempt to analyze case where range was in error
- if Error_Posted (Scalar_Range (E)) then
+ if No (Scalar_Range (E))
+ or else Error_Posted (Scalar_Range (E))
+ then
return;
end if;
end loop;
end Check_Unsigned_Type;
- -----------------------------
- -- Expand_Atomic_Aggregate --
- -----------------------------
+ -------------------------
+ -- Is_Atomic_Aggregate --
+ -------------------------
- procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id) is
+ function Is_Atomic_Aggregate
+ (E : Entity_Id;
+ Typ : Entity_Id) return Boolean
+ is
Loc : constant Source_Ptr := Sloc (E);
New_N : Node_Id;
+ Par : Node_Id;
Temp : Entity_Id;
begin
- if (Nkind (Parent (E)) = N_Object_Declaration
- or else Nkind (Parent (E)) = N_Assignment_Statement)
- and then Comes_From_Source (Parent (E))
- and then Nkind (E) = N_Aggregate
- then
- Temp :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('T'));
+ Par := Parent (E);
+
+ -- Array may be qualified, so find outer context
+ if Nkind (Par) = N_Qualified_Expression then
+ Par := Parent (Par);
+ end if;
+
+ if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement)
+ and then Comes_From_Source (Par)
+ then
+ Temp := Make_Temporary (Loc, 'T', E);
New_N :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
- Object_definition => New_Occurrence_Of (Typ, Loc),
- Expression => Relocate_Node (E));
- Insert_Before (Parent (E), New_N);
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (E));
+ Insert_Before (Par, New_N);
Analyze (New_N);
- Set_Expression (Parent (E), New_Occurrence_Of (Temp, Loc));
-
- -- To prevent the temporary from being constant-folded (which would
- -- lead to the same piecemeal assignment on the original target)
- -- indicate to the back-end that the temporary is a variable with
- -- real storage. See description of this flag in Einfo, and the notes
- -- on N_Assignment_Statement and N_Object_Declaration in Sinfo.
+ Set_Expression (Par, New_Occurrence_Of (Temp, Loc));
+ return True;
- Set_Is_True_Constant (Temp, False);
+ else
+ return False;
end if;
- end Expand_Atomic_Aggregate;
+ end Is_Atomic_Aggregate;
----------------
-- Freeze_All --
-- Freeze_All_Ent --
--------------------
- procedure Freeze_All_Ent
- (From : Entity_Id;
- After : in out Node_Id)
- is
+ procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is
E : Entity_Id;
Flist : List_Id;
Lastn : Node_Id;
begin
Prim := First_Elmt (Prim_List);
-
while Present (Prim) loop
Subp := Node (Prim);
Bod : constant Node_Id := Next (After);
begin
- if (Nkind (Bod) = N_Subprogram_Body
- or else Nkind (Bod) = N_Entry_Body
- or else Nkind (Bod) = N_Package_Body
- or else Nkind (Bod) = N_Protected_Body
- or else Nkind (Bod) = N_Task_Body
+ if (Nkind_In (Bod, N_Subprogram_Body,
+ N_Entry_Body,
+ N_Package_Body,
+ N_Protected_Body,
+ N_Task_Body)
or else Nkind (Bod) in N_Body_Stub)
and then
List_Containing (After) = List_Containing (Parent (E))
-- point at which such functions are constructed (after all types that
-- might be used in such expressions have been frozen).
+ -- For subprograms that are renaming_as_body, we create the wrapper
+ -- bodies as needed.
+
-- We also add finalization chains to access types whose designated
-- types are controlled. This is normally done when freezing the type,
-- but this misses recursive type definitions where the later members
- -- of the recursion introduce controlled components (e.g. 5624-001).
+ -- of the recursion introduce controlled components.
-- Loop through entities
then
declare
Ent : Entity_Id;
+
begin
Ent := First_Entity (E);
-
while Present (Ent) loop
-
if Is_Entry (Ent)
and then not Default_Expressions_Processed (Ent)
then
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type
- and then Controlled_Type (Designated_Type (E))
+ and then Needs_Finalization (Designated_Type (E))
and then No (Associated_Final_Chain (E))
then
Build_Final_List (Parent (E), E);
Formal : Entity_Id;
Atype : Entity_Id;
+ Has_Default_Initialization : Boolean := False;
+ -- This flag gets set to true for a variable with default initialization
+
procedure Check_Current_Instance (Comp_Decl : Node_Id);
-- Check that an Access or Unchecked_Access attribute with a prefix
-- which is the current instance type can only be applied when the type
-- is limited.
+ procedure Check_Suspicious_Modulus (Utype : Entity_Id);
+ -- Give warning for modulus of 8, 16, 32, or 64 given as an explicit
+ -- integer literal without an explicit corresponding size clause. The
+ -- caller has checked that Utype is a modular integer type.
+
function After_Last_Declaration return Boolean;
-- If Loc is a freeze_entity that appears after the last declaration
-- in the scope, inhibit error messages on late completion.
----------------------------
function After_Last_Declaration return Boolean is
- Spec : constant Node_Id := Parent (Current_Scope);
+ Spec : constant Node_Id := Parent (Current_Scope);
begin
if Nkind (Spec) = N_Package_Specification then
if Present (Private_Declarations (Spec)) then
-- either a tagged type, or a limited record.
if Is_Limited_Type (Rec_Type)
- and then
- (Ada_Version < Ada_05
- or else Is_Tagged_Type (Rec_Type))
+ and then (Ada_Version < Ada_05 or else Is_Tagged_Type (Rec_Type))
then
return;
end if;
end Check_Current_Instance;
+ ------------------------------
+ -- Check_Suspicious_Modulus --
+ ------------------------------
+
+ procedure Check_Suspicious_Modulus (Utype : Entity_Id) is
+ Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype));
+
+ begin
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ declare
+ Tdef : constant Node_Id := Type_Definition (Decl);
+ begin
+ if Nkind (Tdef) = N_Modular_Type_Definition then
+ declare
+ Modulus : constant Node_Id :=
+ Original_Node (Expression (Tdef));
+ begin
+ if Nkind (Modulus) = N_Integer_Literal then
+ declare
+ Modv : constant Uint := Intval (Modulus);
+ Sizv : constant Uint := RM_Size (Utype);
+
+ begin
+ -- First case, modulus and size are the same. This
+ -- happens if you have something like mod 32, with
+ -- an explicit size of 32, this is for sure a case
+ -- where the warning is given, since it is seems
+ -- very unlikely that someone would want e.g. a
+ -- five bit type stored in 32 bits. It is much
+ -- more likely they wanted a 32-bit type.
+
+ if Modv = Sizv then
+ null;
+
+ -- Second case, the modulus is 32 or 64 and no
+ -- size clause is present. This is a less clear
+ -- case for giving the warning, but in the case
+ -- of 32/64 (5-bit or 6-bit types) these seem rare
+ -- enough that it is a likely error (and in any
+ -- case using 2**5 or 2**6 in these cases seems
+ -- clearer. We don't include 8 or 16 here, simply
+ -- because in practice 3-bit and 4-bit types are
+ -- more common and too many false positives if
+ -- we warn in these cases.
+
+ elsif not Has_Size_Clause (Utype)
+ and then (Modv = Uint_32 or else Modv = Uint_64)
+ then
+ null;
+
+ -- No warning needed
+
+ else
+ return;
+ end if;
+
+ -- If we fall through, give warning
+
+ Error_Msg_Uint_1 := Modv;
+ Error_Msg_N
+ ("?2 '*'*^' may have been intended here",
+ Modulus);
+ end;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end Check_Suspicious_Modulus;
+
------------------------
-- Freeze_Record_Type --
------------------------
Placed_Component : Boolean := False;
-- Set True if we find at least one component with a component
- -- clause (used to warn about useless Bit_Order pragmas).
+ -- clause (used to warn about useless Bit_Order pragmas, and also
+ -- to detect cases where Implicit_Packing may have an effect).
+
+ All_Scalar_Components : Boolean := True;
+ -- Set False if we encounter a component of a non-scalar type
+
+ Scalar_Component_Total_RM_Size : Uint := Uint_0;
+ Scalar_Component_Total_Esize : Uint := Uint_0;
+ -- Accumulates total RM_Size values and total Esize values of all
+ -- scalar components. Used for processing of Implicit_Packing.
function Check_Allocator (N : Node_Id) return Node_Id;
-- If N is an allocator, possibly wrapped in one or more level of
Prev := Empty;
while Present (Comp) loop
- -- First handle the (real) component case
+ -- First handle the component case
if Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant
Component_Name (Component_Clause (Comp)));
end if;
end if;
+ end;
+ end if;
- -- If component clause is present, then deal with the non-
- -- default bit order case for Ada 95 mode. The required
- -- processing for Ada 2005 mode is handled separately after
- -- processing all components.
-
- -- We only do this processing for the base type, and in
- -- fact that's important, since otherwise if there are
- -- record subtypes, we could reverse the bits once for
- -- each subtype, which would be incorrect.
-
- if Present (CC)
- and then Reverse_Bit_Order (Rec)
- and then Ekind (E) = E_Record_Type
- and then Ada_Version <= Ada_95
- then
- declare
- CFB : constant Uint := Component_Bit_Offset (Comp);
- CSZ : constant Uint := Esize (Comp);
- CLC : constant Node_Id := Component_Clause (Comp);
- Pos : constant Node_Id := Position (CLC);
- FB : constant Node_Id := First_Bit (CLC);
-
- Storage_Unit_Offset : constant Uint :=
- CFB / System_Storage_Unit;
-
- Start_Bit : constant Uint :=
- CFB mod System_Storage_Unit;
-
- begin
- -- Cases where field goes over storage unit boundary
-
- if Start_Bit + CSZ > System_Storage_Unit then
-
- -- Allow multi-byte field but generate warning
-
- if Start_Bit mod System_Storage_Unit = 0
- and then CSZ mod System_Storage_Unit = 0
- then
- Error_Msg_N
- ("multi-byte field specified with non-standard"
- & " Bit_Order?", CLC);
-
- if Bytes_Big_Endian then
- Error_Msg_N
- ("bytes are not reversed "
- & "(component is big-endian)?", CLC);
- else
- Error_Msg_N
- ("bytes are not reversed "
- & "(component is little-endian)?", CLC);
- end if;
-
- -- Do not allow non-contiguous field
-
- else
- Error_Msg_N
- ("attempt to specify non-contiguous field"
- & " not permitted", CLC);
- Error_Msg_N
- ("\(caused by non-standard Bit_Order "
- & "specified)", CLC);
- end if;
-
- -- Case where field fits in one storage unit
-
- else
- -- Give warning if suspicious component clause
-
- if Intval (FB) >= System_Storage_Unit
- and then Warn_On_Reverse_Bit_Order
- then
- Error_Msg_N
- ("?Bit_Order clause does not affect " &
- "byte ordering", Pos);
- Error_Msg_Uint_1 :=
- Intval (Pos) + Intval (FB) /
- System_Storage_Unit;
- Error_Msg_N
- ("?position normalized to ^ before bit " &
- "order interpreted", Pos);
- end if;
-
- -- Here is where we fix up the Component_Bit_Offset
- -- value to account for the reverse bit order.
- -- Some examples of what needs to be done are:
-
- -- First_Bit .. Last_Bit Component_Bit_Offset
- -- old new old new
-
- -- 0 .. 0 7 .. 7 0 7
- -- 0 .. 1 6 .. 7 0 6
- -- 0 .. 2 5 .. 7 0 5
- -- 0 .. 7 0 .. 7 0 4
-
- -- 1 .. 1 6 .. 6 1 6
- -- 1 .. 4 3 .. 6 1 3
- -- 4 .. 7 0 .. 3 4 0
-
- -- The general rule is that the first bit is
- -- is obtained by subtracting the old ending bit
- -- from storage_unit - 1.
-
- Set_Component_Bit_Offset
- (Comp,
- (Storage_Unit_Offset * System_Storage_Unit) +
- (System_Storage_Unit - 1) -
- (Start_Bit + CSZ - 1));
+ -- Gather data for possible Implicit_Packing later. Note that at
+ -- this stage we might be dealing with a real component, or with
+ -- an implicit subtype declaration.
- Set_Normalized_First_Bit
- (Comp,
- Component_Bit_Offset (Comp) mod
- System_Storage_Unit);
- end if;
- end;
- end if;
- end;
+ if not Is_Scalar_Type (Etype (Comp)) then
+ All_Scalar_Components := False;
+ else
+ Scalar_Component_Total_RM_Size :=
+ Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
+ Scalar_Component_Total_Esize :=
+ Scalar_Component_Total_Esize + Esize (Etype (Comp));
end if;
-- If the component is an Itype with Delayed_Freeze and is either
-- a record or array subtype and its base type has not yet been
- -- frozen, we must remove this from the entity list of this
- -- record and put it on the entity list of the scope of its base
- -- type. Note that we know that this is not the type of a
- -- component since we cleared Has_Delayed_Freeze for it in the
- -- previous loop. Thus this must be the Designated_Type of an
- -- access type, which is the type of a component.
+ -- frozen, we must remove this from the entity list of this record
+ -- and put it on the entity list of the scope of its base type.
+ -- Note that we know that this is not the type of a component
+ -- since we cleared Has_Delayed_Freeze for it in the previous
+ -- loop. Thus this must be the Designated_Type of an access type,
+ -- which is the type of a component.
if Is_Itype (Comp)
and then Is_Type (Scope (Comp))
Next_Entity (Comp);
end loop;
- -- Deal with pragma Bit_Order
+ -- Deal with pragma Bit_Order setting non-standard bit order
if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
if not Placed_Component then
ADC :=
Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
- Error_Msg_N
- ("?Bit_Order specification has no effect", ADC);
+ Error_Msg_N ("?Bit_Order specification has no effect", ADC);
Error_Msg_N
("\?since no component clauses were specified", ADC);
- -- Here is where we do Ada 2005 processing for bit order (the Ada
- -- 95 case was already taken care of above).
+ -- Here is where we do the processing for reversed bit order
- elsif Ada_Version >= Ada_05 then
+ else
Adjust_Record_For_Reverse_Bit_Order (Rec);
end if;
end if;
+ -- Complete error checking on record representation clause (e.g.
+ -- overlap of components). This is called after adjusting the
+ -- record for reverse bit order.
+
+ declare
+ RRC : constant Node_Id := Get_Record_Representation_Clause (Rec);
+ begin
+ if Present (RRC) then
+ Check_Record_Representation_Clause (RRC);
+ end if;
+ end;
+
-- Set OK_To_Reorder_Components depending on debug flags
if Rec = Base_Type (Rec)
-- Give warning if redundant constructs warnings on
if Warn_On_Redundant_Constructs then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("?pragma Pack has no effect, no unplaced components",
Get_Rep_Pragma (Rec, Name_Pack));
end if;
-- Finally, enforce the restriction that access attributes with a
-- current instance prefix can only apply to limited types.
- if Ekind (Rec) = E_Record_Type then
+ if Ekind (Rec) = E_Record_Type then
if Present (Corresponding_Remote_Type (Rec)) then
Freeze_And_Append
(Corresponding_Remote_Type (Rec), Loc, Result);
Comp := First_Component (Rec);
while Present (Comp) loop
- if Has_Controlled_Component (Etype (Comp))
- or else (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Etype (Comp)))
- or else (Is_Protected_Type (Etype (Comp))
- and then Present
- (Corresponding_Record_Type (Etype (Comp)))
- and then Has_Controlled_Component
- (Corresponding_Record_Type (Etype (Comp))))
+
+ -- Do not set Has_Controlled_Component on a class-wide
+ -- equivalent type. See Make_CW_Equivalent_Type.
+
+ if not Is_Class_Wide_Equivalent_Type (Rec)
+ and then (Has_Controlled_Component (Etype (Comp))
+ or else (Chars (Comp) /= Name_uParent
+ and then Is_Controlled (Etype (Comp)))
+ or else (Is_Protected_Type (Etype (Comp))
+ and then Present
+ (Corresponding_Record_Type
+ (Etype (Comp)))
+ and then Has_Controlled_Component
+ (Corresponding_Record_Type
+ (Etype (Comp)))))
then
Set_Has_Controlled_Component (Rec);
exit;
end if;
end;
end if;
+
+ -- See if Size is too small as is (and implicit packing might help)
+
+ if not Is_Packed (Rec)
+
+ -- No implicit packing if even one component is explicitly placed
+
+ and then not Placed_Component
+
+ -- Must have size clause and all scalar components
+
+ and then Has_Size_Clause (Rec)
+ and then All_Scalar_Components
+
+ -- Do not try implicit packing on records with discriminants, too
+ -- complicated, especially in the variant record case.
+
+ and then not Has_Discriminants (Rec)
+
+ -- We can implicitly pack if the specified size of the record is
+ -- less than the sum of the object sizes (no point in packing if
+ -- this is not the case).
+
+ and then Esize (Rec) < Scalar_Component_Total_Esize
+
+ -- And the total RM size cannot be greater than the specified size
+ -- since otherwise packing will not get us where we have to be!
+
+ and then Esize (Rec) >= Scalar_Component_Total_RM_Size
+
+ -- Never do implicit packing in CodePeer mode since we don't do
+ -- any packing ever in this mode (why not???)
+
+ and then not CodePeer_Mode
+ then
+ -- If implicit packing enabled, do it
+
+ if Implicit_Packing then
+ Set_Is_Packed (Rec);
+
+ -- Otherwise flag the size clause
+
+ else
+ declare
+ Sz : constant Node_Id := Size_Clause (Rec);
+ begin
+ Error_Msg_NE -- CODEFIX
+ ("size given for& too small", Sz, Rec);
+ Error_Msg_N -- CODEFIX
+ ("\use explicit pragma Pack "
+ & "or use pragma Implicit_Packing", Sz);
+ end;
+ end if;
+ end if;
end Freeze_Record_Type;
-- Start of processing for Freeze_Entity
S : Entity_Id := Current_Scope;
begin
+
while Present (S) loop
if Is_Overloadable (S) then
if Comes_From_Source (S)
-- If entity is exported or imported and does not have an external
-- name, now is the time to provide the appropriate default name.
-- Skip this if the entity is stubbed, since we don't need a name
- -- for any stubbed routine.
+ -- for any stubbed routine. For the case on intrinsics, if no
+ -- external name is specified, then calls will be handled in
+ -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an
+ -- external name is provided, then Expand_Intrinsic_Call leaves
+ -- calls in place for expansion by GIGI.
if (Is_Imported (E) or else Is_Exported (E))
and then No (Interface_Name (E))
and then Convention (E) /= Convention_Stubbed
+ and then Convention (E) /= Convention_Intrinsic
then
Set_Encoded_Interface_Name
(E, Get_Default_External_Name (E));
- -- Special processing for atomic objects appearing in object decls
+ -- If entity is an atomic object appearing in a declaration and
+ -- the expression is an aggregate, assign it to a temporary to
+ -- ensure that the actual assignment is done atomically rather
+ -- than component-wise (the assignment to the temp may be done
+ -- component-wise, but that is harmless).
elsif Is_Atomic (E)
and then Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
+ and then Nkind (Expression (Parent (E))) = N_Aggregate
+ and then
+ Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E))
then
- declare
- Expr : constant Node_Id := Expression (Parent (E));
-
- begin
- -- If expression is an aggregate, assign to a temporary to
- -- ensure that the actual assignment is done atomically rather
- -- than component-wise (the assignment to the temp may be done
- -- component-wise, but that is harmless).
-
- if Nkind (Expr) = N_Aggregate then
- Expand_Atomic_Aggregate (Expr, Etype (E));
-
- -- If the expression is a reference to a record or array object
- -- entity, then reset Is_True_Constant to False so that the
- -- compiler will not optimize away the intermediate object,
- -- which we need in this case for the same reason (to ensure
- -- that the actual assignment is atomic, rather than
- -- component-wise).
-
- elsif Is_Entity_Name (Expr)
- and then (Is_Record_Type (Etype (Expr))
- or else
- Is_Array_Type (Etype (Expr)))
- then
- Set_Is_True_Constant (Entity (Expr), False);
- end if;
- end;
+ null;
end if;
-- For a subprogram, freeze all parameter types and also the return
-- type (RM 13.14(14)). However skip this for internal subprograms.
-- This is also the point where any extra formal parameters are
- -- created since we now know whether the subprogram will use
- -- a foreign convention.
+ -- created since we now know whether the subprogram will use a
+ -- foreign convention.
if Is_Subprogram (E) then
if not Is_Internal (E) then
-- If the type of a formal is incomplete, subprogram
-- is being frozen prematurely. Within an instance
-- (but not within a wrapper package) this is an
- -- an artifact of our need to regard the end of an
+ -- artifact of our need to regard the end of an
-- instantiation as a freeze point. Otherwise it is
-- a definite error.
- -- and then not Is_Wrapper_Package (Current_Scope) ???
-
if In_Instance then
Set_Is_Frozen (E, False);
return No_List;
and then not Has_Warnings_Off (F_Type)
and then not Has_Warnings_Off (Formal)
then
+ -- Qualify mention of formals with subprogram name
+
Error_Msg_Qual_Level := 1;
-- Check suspicious use of fat C pointer
and then Esize (F_Type) > Ttypes.System_Address_Size
then
Error_Msg_N
- ("?type of & does not correspond "
- & "to C pointer!", Formal);
+ ("?type of & does not correspond to C pointer!",
+ Formal);
-- Check suspicious return of boolean
elsif Root_Type (F_Type) = Standard_Boolean
and then Convention (F_Type) = Convention_Ada
+ and then not Has_Warnings_Off (F_Type)
+ and then not Has_Size_Clause (F_Type)
+ and then VM_Target = No_VM
then
+ Error_Msg_N ("& is an 8-bit Ada Boolean?", Formal);
Error_Msg_N
- ("?& is an 8-bit Ada Boolean, "
- & "use char in C!", Formal);
+ ("\use appropriate corresponding type in C "
+ & "(e.g. char)?", Formal);
-- Check suspicious tagged type
and then Convention (E) = Convention_C
then
Error_Msg_N
- ("?& is a tagged type which does not "
+ ("?& involves a tagged type which does not "
& "correspond to any C type!", Formal);
-- Check wrong convention subprogram pointer
Formal, F_Type);
end if;
+ -- Turn off name qualification after message output
+
Error_Msg_Qual_Level := 0;
end if;
and then Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
and then Warn_On_Export_Import
+
+ -- Exclude VM case, since both .NET and JVM can handle
+ -- unconstrained arrays without a problem.
+
+ and then VM_Target = No_VM
then
Error_Msg_Qual_Level := 1;
Error_Msg_Qual_Level := 0;
end if;
- -- Ada 2005 (AI-326): Check wrong use of tag incomplete
- -- types with unknown discriminants. For example:
-
- -- type T (<>) is tagged;
- -- procedure P (X : access T); -- ERROR
- -- procedure P (X : T); -- ERROR
-
if not From_With_Type (F_Type) then
if Is_Access_Type (F_Type) then
F_Type := Designated_Type (F_Type);
end if;
- if Ekind (F_Type) = E_Incomplete_Type
- and then Is_Tagged_Type (F_Type)
- and then not Is_Class_Wide_Type (F_Type)
- and then No (Full_View (F_Type))
- and then Unknown_Discriminants_Present
- (Parent (F_Type))
- and then No (Stored_Constraint (F_Type))
- then
- Error_Msg_N
- ("(Ada 2005): invalid use of unconstrained tagged"
- & " incomplete type", E);
-
-- If the formal is an anonymous_access_to_subprogram
-- freeze the subprogram type as well, to prevent
-- scope anomalies in gigi, because there is no other
-- clear point at which it could be frozen.
- elsif Is_Itype (Etype (Formal))
+ if Is_Itype (Etype (Formal))
and then Ekind (F_Type) = E_Subprogram_Type
then
Freeze_And_Append (F_Type, Loc, Result);
Next_Formal (Formal);
end loop;
- -- Case of function
+ -- Case of function: similar checks on return type
if Ekind (E) = E_Function then
elsif Root_Type (R_Type) = Standard_Boolean
and then Convention (R_Type) = Convention_Ada
+ and then VM_Target = No_VM
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
+ and then not Has_Size_Clause (R_Type)
then
- Error_Msg_N
- ("?return type of & is an 8-bit "
- & "Ada Boolean, use char in C!", E);
+ declare
+ N : constant Node_Id :=
+ Result_Definition (Declaration_Node (E));
+ begin
+ Error_Msg_NE
+ ("return type of & is an 8-bit Ada Boolean?",
+ N, E);
+ Error_Msg_NE
+ ("\use appropriate corresponding type in C "
+ & "(e.g. char)?", N, E);
+ end;
-- Check suspicious return tagged type
end if;
end if;
- if Is_Array_Type (Etype (E))
- and then not Is_Constrained (Etype (E))
+ -- Give warning for suspicous return of a result of an
+ -- unconstrained array type in a foreign convention
+ -- function.
+
+ if Has_Foreign_Convention (E)
+
+ -- We are looking for a return of unconstrained array
+
+ and then Is_Array_Type (R_Type)
+ and then not Is_Constrained (R_Type)
+
+ -- Exclude imported routines, the warning does not
+ -- belong on the import, but on the routine definition.
+
and then not Is_Imported (E)
- and then Has_Foreign_Convention (E)
+
+ -- Exclude VM case, since both .NET and JVM can handle
+ -- return of unconstrained arrays without a problem.
+
+ and then VM_Target = No_VM
+
+ -- Check that general warning is enabled, and that it
+ -- is not suppressed for this particular case.
+
and then Warn_On_Export_Import
and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (Etype (E))
+ and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("?foreign convention function& should not " &
"return unconstrained array!", E);
-
- -- Ada 2005 (AI-326): Check wrong use of tagged
- -- incomplete type
- --
- -- type T is tagged;
- -- function F (X : Boolean) return T; -- ERROR
-
- elsif Ekind (Etype (E)) = E_Incomplete_Type
- and then Is_Tagged_Type (Etype (E))
- and then No (Full_View (Etype (E)))
- and then not Is_Value_Type (Etype (E))
- then
- Error_Msg_N
- ("(Ada 2005): invalid use of tagged incomplete type",
- E);
end if;
end if;
end;
if Nkind (Declaration_Node (E)) = N_Object_Declaration then
+ -- Abstract type allowed only for C++ imported variables or
+ -- constants.
+
+ -- Note: we inhibit this check for objects that do not come
+ -- from source because there is at least one case (the
+ -- expansion of x'class'input where x is abstract) where we
+ -- legitimately generate an abstract object.
+
+ if Is_Abstract_Type (Etype (E))
+ and then Comes_From_Source (Parent (E))
+ and then not (Is_Imported (E)
+ and then Is_CPP_Class (Etype (E)))
+ then
+ Error_Msg_N ("type of object cannot be abstract",
+ Object_Definition (Parent (E)));
+
+ if Is_CPP_Class (Etype (E)) then
+ Error_Msg_NE
+ ("\} may need a cpp_constructor",
+ Object_Definition (Parent (E)), Etype (E));
+ end if;
+ end if;
+
-- For object created by object declaration, perform required
-- categorization (preelaborate and pure) checks. Defer these
-- checks to freeze time since pragma Import inhibits default
Validate_Object_Declaration (Declaration_Node (E));
- -- If there is an address clause, check it is valid
+ -- If there is an address clause, check that it is valid
Check_Address_Clause (E);
+ -- If the object needs any kind of default initialization, an
+ -- error must be issued if No_Default_Initialization applies.
+ -- The check doesn't apply to imported objects, which are not
+ -- ever default initialized, and is why the check is deferred
+ -- until freezing, at which point we know if Import applies.
+ -- Deferred constants are also exempted from this test because
+ -- their completion is explicit, or through an import pragma.
+
+ if Ekind (E) = E_Constant
+ and then Present (Full_View (E))
+ then
+ null;
+
+ elsif Comes_From_Source (E)
+ and then not Is_Imported (E)
+ and then not Has_Init_Expression (Declaration_Node (E))
+ and then
+ ((Has_Non_Null_Base_Init_Proc (Etype (E))
+ and then not No_Initialization (Declaration_Node (E))
+ and then not Is_Value_Type (Etype (E))
+ and then not Suppress_Init_Proc (Etype (E)))
+ or else
+ (Needs_Simple_Initialization (Etype (E))
+ and then not Is_Internal (E)))
+ then
+ Has_Default_Initialization := True;
+ Check_Restriction
+ (No_Default_Initialization, Declaration_Node (E));
+ end if;
+
+ -- Check that a Thread_Local_Storage variable does not have
+ -- default initialization, and any explicit initialization must
+ -- either be the null constant or a static constant.
+
+ if Has_Pragma_Thread_Local_Storage (E) then
+ declare
+ Decl : constant Node_Id := Declaration_Node (E);
+ begin
+ if Has_Default_Initialization
+ or else
+ (Has_Init_Expression (Decl)
+ and then
+ (No (Expression (Decl))
+ or else not
+ (Is_Static_Expression (Expression (Decl))
+ or else
+ Nkind (Expression (Decl)) = N_Null)))
+ then
+ Error_Msg_NE
+ ("Thread_Local_Storage variable& is "
+ & "improperly initialized", Decl, E);
+ Error_Msg_NE
+ ("\only allowed initialization is explicit "
+ & "NULL or static expression", Decl, E);
+ end if;
+ end;
+ end if;
+
-- For imported objects, set Is_Public unless there is also an
-- address clause, which means that there is no external symbol
-- needed for the Import (Is_Public may still be set for other
and then not Is_Limited_Composite (E)
and then not Is_Packed (Root_Type (E))
and then not Has_Component_Size_Clause (Root_Type (E))
+ and then not CodePeer_Mode
then
Get_Index_Bounds (First_Index (E), Lo, Hi);
-- was a pragma Pack (resulting in the component size
-- being the same as the RM_Size). Furthermore, the
-- component type size must be an odd size (not a
- -- multiple of storage unit)
+ -- multiple of storage unit). If the component RM size
+ -- is an exact number of storage units that is a power
+ -- of two, the array is not packed and has a standard
+ -- representation.
begin
if RM_Size (E) = Len * Rsiz
and then Rsiz mod System_Storage_Unit /= 0
then
-- For implicit packing mode, just set the
- -- component size silently
+ -- component size silently.
if Implicit_Packing then
Set_Component_Size (Btyp, Rsiz);
else
Error_Msg_NE
("size given for& too small", SZ, E);
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("\use explicit pragma Pack "
& "or use pragma Implicit_Packing", SZ);
end if;
+
+ elsif RM_Size (E) = Len * Rsiz
+ and then Implicit_Packing
+ and then
+ (Rsiz / System_Storage_Unit = 1
+ or else Rsiz / System_Storage_Unit = 2
+ or else Rsiz / System_Storage_Unit = 4)
+ then
+
+ -- Not a packed array, but indicate the desired
+ -- component size, for the back-end.
+
+ Set_Component_Size (Btyp, Rsiz);
end if;
end;
end if;
-- processing is only done for base types, since all the
-- representation aspects involved are type-related. This
-- is not just an optimization, if we start processing the
- -- subtypes, they intefere with the settings on the base
+ -- subtypes, they interfere with the settings on the base
-- type (this is because Is_Packed has a slightly different
-- meaning before and after freezing).
-- For bit-packed arrays, check the size
- if Is_Bit_Packed_Array (E)
- and then Known_RM_Size (E)
- then
+ if Is_Bit_Packed_Array (E) and then Known_RM_Size (E) then
declare
SizC : constant Node_Id := Size_Clause (E);
end if;
-- The equivalent type associated with a class-wide subtype needs
- -- to be frozen to ensure that its layout is done. Class-wide
- -- subtypes are currently only frozen on targets requiring
- -- front-end layout (see New_Class_Wide_Subtype and
- -- Make_CW_Equivalent_Type in exp_util.adb).
+ -- to be frozen to ensure that its layout is done.
if Ekind (E) = E_Class_Wide_Subtype
and then Present (Equivalent_Type (E))
-- later when the full type is frozen).
elsif Ekind (E) = E_Record_Type
- or else Ekind (E) = E_Record_Subtype
+ or else Ekind (E) = E_Record_Subtype
then
Freeze_Record_Type (E);
-- For a concurrent type, freeze corresponding record type. This
- -- does not correpond to any specific rule in the RM, but the
+ -- does not correspond to any specific rule in the RM, but the
-- record type is essentially part of the concurrent type.
-- Freeze as well all local entities. This includes record types
-- created for entry parameter blocks, and whatever local entities
end if;
Comp := First_Entity (E);
-
while Present (Comp) loop
if Is_Type (Comp) then
Freeze_And_Append (Comp, Loc, Result);
-- For access subprogram, freeze types of all formals, the return
-- type was already frozen, since it is the Etype of the function.
+ -- Formal types can be tagged Taft amendment types, but otherwise
+ -- they cannot be incomplete.
elsif Ekind (E) = E_Subprogram_Type then
Formal := First_Formal (E);
+
while Present (Formal) loop
+ if Ekind (Etype (Formal)) = E_Incomplete_Type
+ and then No (Full_View (Etype (Formal)))
+ and then not Is_Value_Type (Etype (Formal))
+ then
+ if Is_Tagged_Type (Etype (Formal)) then
+ null;
+ else
+ Error_Msg_NE
+ ("invalid use of incomplete type&", E, Etype (Formal));
+ end if;
+ end if;
+
Freeze_And_Append (Etype (Formal), Loc, Result);
Next_Formal (Formal);
end loop;
Freeze_Subprogram (E);
- -- Ada 2005 (AI-326): Check wrong use of tag incomplete type
-
- -- type T is tagged;
- -- type Acc is access function (X : T) return T; -- ERROR
-
- if Ekind (Etype (E)) = E_Incomplete_Type
- and then Is_Tagged_Type (Etype (E))
- and then No (Full_View (Etype (E)))
- and then not Is_Value_Type (Etype (E))
- then
- Error_Msg_N
- ("(Ada 2005): invalid use of tagged incomplete type", E);
- end if;
-
-- For access to a protected subprogram, freeze the equivalent type
-- (however this is not set if we are not generating code or if this
-- is an anonymous type used just for resolution).
elsif Is_Access_Protected_Subprogram_Type (E) then
-
- -- AI-326: Check wrong use of tagged incomplete types
-
- -- type T is tagged;
- -- type As3D is access protected
- -- function (X : Float) return T; -- ERROR
-
- declare
- Etyp : Entity_Id;
-
- begin
- Etyp := Etype (Directly_Designated_Type (E));
-
- if Is_Class_Wide_Type (Etyp) then
- Etyp := Etype (Etyp);
- end if;
-
- if Ekind (Etyp) = E_Incomplete_Type
- and then Is_Tagged_Type (Etyp)
- and then No (Full_View (Etyp))
- and then not Is_Value_Type (Etype (E))
- then
- Error_Msg_N
- ("(Ada 2005): invalid use of tagged incomplete type", E);
- end if;
- end;
-
if Present (Equivalent_Type (E)) then
Freeze_And_Append (Equivalent_Type (E), Loc, Result);
end if;
elsif Is_Integer_Type (E) then
Adjust_Esize_For_Alignment (E);
+ if Is_Modular_Integer_Type (E)
+ and then Warn_On_Suspicious_Modulus_Value
+ then
+ Check_Suspicious_Modulus (E);
+ end if;
+
elsif Is_Access_Type (E) then
-- Check restriction for standard storage pool
if Is_Pure_Unit_Access_Type (E)
and then (Ada_Version < Ada_05
- or else not No_Pool_Assigned (E))
+ or else not No_Pool_Assigned (E))
then
Error_Msg_N ("named access type not allowed in pure unit", E);
+
+ if Ada_Version >= Ada_05 then
+ Error_Msg_N
+ ("\would be legal if Storage_Size of 0 given?", E);
+
+ elsif No_Pool_Assigned (E) then
+ Error_Msg_N
+ ("\would be legal in Ada 2005?", E);
+
+ else
+ Error_Msg_N
+ ("\would be legal in Ada 2005 if "
+ & "Storage_Size of 0 given?", E);
+ end if;
end if;
end if;
end if;
end if;
- -- Generate primitive operation references for a tagged type
-
- if Is_Tagged_Type (E)
- and then not Is_Class_Wide_Type (E)
- then
- declare
- Prim_List : Elist_Id;
- Prim : Elmt_Id;
- Ent : Entity_Id;
- Aux_E : Entity_Id;
-
- begin
- -- Handle subtypes
-
- if Ekind (E) = E_Protected_Subtype
- or else Ekind (E) = E_Task_Subtype
- then
- Aux_E := Etype (E);
- else
- Aux_E := E;
- end if;
-
- -- Ada 2005 (AI-345): In case of concurrent type generate
- -- reference to the wrapper that allow us to dispatch calls
- -- through their implemented abstract interface types.
-
- -- The check for Present here is to protect against previously
- -- reported critical errors.
-
- if Is_Concurrent_Type (Aux_E)
- and then Present (Corresponding_Record_Type (Aux_E))
- then
- Prim_List := Primitive_Operations
- (Corresponding_Record_Type (Aux_E));
- else
- Prim_List := Primitive_Operations (Aux_E);
- end if;
-
- -- Loop to generate references for primitive operations
-
- if Present (Prim_List) then
- Prim := First_Elmt (Prim_List);
- while Present (Prim) loop
-
- -- If the operation is derived, get the original for
- -- cross-reference purposes (it is the original for
- -- which we want the xref, and for which the comes
- -- from source test needs to be performed).
-
- Ent := Node (Prim);
- while Present (Alias (Ent)) loop
- Ent := Alias (Ent);
- end loop;
-
- Generate_Reference (E, Ent, 'p', Set_Ref => False);
- Next_Elmt (Prim);
- end loop;
- end if;
- end;
- end if;
-
-- Now that all types from which E may depend are frozen, see if the
-- size is known at compile time, if it must be unsigned, or if
-- strict alignment is required
if Has_Size_Clause (E)
and then not Size_Known_At_Compile_Time (E)
then
- -- Supress this message if errors posted on E, even if we are
+ -- Suppress this message if errors posted on E, even if we are
-- in all errors mode, since this is often a junk message
if not Error_Posted (E) then
procedure Freeze_Enumeration_Type (Typ : Entity_Id) is
begin
+ -- By default, if no size clause is present, an enumeration type with
+ -- Convention C is assumed to interface to a C enum, and has integer
+ -- size. This applies to types. For subtypes, verify that its base
+ -- type has no size clause either.
+
if Has_Foreign_Convention (Typ)
and then not Has_Size_Clause (Typ)
+ and then not Has_Size_Clause (Base_Type (Typ))
and then Esize (Typ) < Standard_Integer_Size
then
Init_Esize (Typ, Standard_Integer_Size);
+
else
+ -- If the enumeration type interfaces to C, and it has a size clause
+ -- that specifies less than int size, it warrants a warning. The
+ -- user may intend the C type to be an enum or a char, so this is
+ -- not by itself an error that the Ada compiler can detect, but it
+ -- it is a worth a heads-up. For Boolean and Character types we
+ -- assume that the programmer has the proper C type in mind.
+
+ if Convention (Typ) = Convention_C
+ and then Has_Size_Clause (Typ)
+ and then Esize (Typ) /= Esize (Standard_Integer)
+ and then not Is_Boolean_Type (Typ)
+ and then not Is_Character_Type (Typ)
+ then
+ Error_Msg_N
+ ("C enum types have the size of a C int?", Size_Clause (Typ));
+ end if;
+
Adjust_Esize_For_Alignment (Typ);
end if;
end Freeze_Enumeration_Type;
-----------------------
procedure Freeze_Expression (N : Node_Id) is
- In_Def_Exp : constant Boolean := In_Default_Expression;
- Typ : Entity_Id;
- Nam : Entity_Id;
- Desig_Typ : Entity_Id;
- P : Node_Id;
- Parent_P : Node_Id;
+ In_Spec_Exp : constant Boolean := In_Spec_Expression;
+ Typ : Entity_Id;
+ Nam : Entity_Id;
+ Desig_Typ : Entity_Id;
+ P : Node_Id;
+ Parent_P : Node_Id;
Freeze_Outside : Boolean := False;
-- This flag is set true if the entity must be frozen outside the
-- make sure that we actually have a real expression (if we have
-- a subtype indication, we can't test Is_Static_Expression!)
- if In_Def_Exp
+ if In_Spec_Exp
and then Nkind (N) in N_Subexpr
and then not Is_Static_Expression (N)
then
-- designated type is a private type without full view, the expression
-- cannot contain an allocator, so the type is not frozen.
+ -- For a function, we freeze the entity when the subprogram declaration
+ -- is frozen, but a function call may appear in an initialization proc.
+ -- before the declaration is frozen. We need to generate the extra
+ -- formals, if any, to ensure that the expansion of the call includes
+ -- the proper actuals. This only applies to Ada subprograms, not to
+ -- imported ones.
+
Desig_Typ := Empty;
case Nkind (N) is
Desig_Typ := Designated_Type (Etype (Prefix (N)));
end if;
+ when N_Identifier =>
+ if Present (Nam)
+ and then Ekind (Nam) = E_Function
+ and then Nkind (Parent (N)) = N_Function_Call
+ and then Convention (Nam) = Convention_Ada
+ then
+ Create_Extra_Formals (Nam);
+ end if;
+
when others =>
null;
end case;
return;
end if;
- -- Loop for looking at the right place to insert the freeze nodes
+ -- Loop for looking at the right place to insert the freeze nodes,
-- exiting from the loop when it is appropriate to insert the freeze
-- node before the current node P.
-- For either of these cases, we skip the freezing
- if not In_Default_Expression
+ if not In_Spec_Expression
and then Nkind (N) = N_Identifier
and then (Present (Entity (N)))
then
and then Is_Enumeration_Type (Etype (N))
then
-- If enumeration literal appears directly as the choice,
- -- do not freeze (this is the normal non-overloade case)
+ -- do not freeze (this is the normal non-overloaded case)
if Nkind (Parent (N)) = N_Component_Association
and then First (Choices (Parent (N))) = N
N_Entry_Call_Alternative |
N_Triggering_Alternative |
N_Abortable_Part |
+ N_And_Then |
+ N_Or_Else |
N_Freeze_Entity =>
exit when Is_List_Member (P);
-- static type, and the freeze scope needs to be the outer scope, not
-- the scope of the subprogram with the default parameter.
- -- For default expressions in generic units, the Move_Freeze_Nodes
- -- mechanism (see sem_ch12.adb) takes care of placing them at the proper
- -- place, after the generic unit.
+ -- For default expressions and other spec expressions in generic units,
+ -- the Move_Freeze_Nodes mechanism (see sem_ch12.adb) takes care of
+ -- placing them at the proper place, after the generic unit.
- if (In_Def_Exp and not Inside_A_Generic)
+ if (In_Spec_Exp and not Inside_A_Generic)
or else Freeze_Outside
or else (Is_Type (Current_Scope)
and then (not Is_Concurrent_Type (Current_Scope)
Scope_Stack.Table (Pos).Pending_Freeze_Actions :=
Freeze_Nodes;
else
- Append_List (Freeze_Nodes, Scope_Stack.Table
- (Pos).Pending_Freeze_Actions);
+ Append_List (Freeze_Nodes,
+ Scope_Stack.Table (Pos).Pending_Freeze_Actions);
end if;
end if;
end;
end if;
-- Now we have the right place to do the freezing. First, a special
- -- adjustment, if we are in default expression analysis mode, these
- -- freeze actions must not be thrown away (normally all inserted actions
- -- are thrown away in this mode. However, the freeze actions are from
- -- static expressions and one of the important reasons we are doing this
+ -- adjustment, if we are in spec-expression analysis mode, these freeze
+ -- actions must not be thrown away (normally all inserted actions are
+ -- thrown away in this mode. However, the freeze actions are from static
+ -- expressions and one of the important reasons we are doing this
-- special analysis is to get these freeze actions. Therefore we turn
- -- off the In_Default_Expression mode to propagate these freeze actions.
+ -- off the In_Spec_Expression mode to propagate these freeze actions.
-- This also means they get properly analyzed and expanded.
- In_Default_Expression := False;
+ In_Spec_Expression := False;
-- Freeze the designated type of an allocator (RM 13.14(13))
Freeze_Before (P, Nam);
end if;
- In_Default_Expression := In_Def_Exp;
+ -- Restore In_Spec_Expression flag
+
+ In_Spec_Expression := In_Spec_Exp;
end Freeze_Expression;
-----------------------------
-- case of both bounds negative, because the sign will be dealt
-- with anyway. Furthermore we can't just go making such a bound
-- symmetrical, since in a twos-complement system, there is an
- -- extra negative value which could not be accomodated on the
+ -- extra negative value which could not be accommodated on the
-- positive side.
if Typ = Btyp
exception
when Cannot_Be_Static =>
- -- If the object that cannot be static is imported or exported,
- -- then we give an error message saying that this object cannot
- -- be imported or exported.
+ -- If the object that cannot be static is imported or exported, then
+ -- issue an error message saying that this object cannot be imported
+ -- or exported. If it has an address clause it is an overlay in the
+ -- current partition and the static requirement is not relevant.
+ -- Do not issue any error message when ignoring rep clauses.
- if Is_Imported (E) then
- Error_Msg_N
- ("& cannot be imported (local type is not constant)", E);
+ if Ignore_Rep_Clauses then
+ null;
+
+ elsif Is_Imported (E) then
+ if No (Address_Clause (E)) then
+ Error_Msg_N
+ ("& cannot be imported (local type is not constant)", E);
+ end if;
-- Otherwise must be exported, something is wrong if compiler
-- is marking something as statically allocated which cannot be).
elsif Is_Generic_Type (Etype (E)) then
null;
+ -- Display warning if returning unconstrained array
+
elsif Is_Array_Type (Retype)
and then not Is_Constrained (Retype)
+
+ -- Exclude cases where descriptor mechanism is set, since the
+ -- VMS descriptor mechanisms allow such unconstrained returns.
+
and then Mechanism (E) not in Descriptor_Codes
+
+ -- Check appropriate warning is enabled (should we check for
+ -- Warnings (Off) on specific entities here, probably so???)
+
and then Warn_On_Export_Import
+
+ -- Exclude the VM case, since return of unconstrained arrays
+ -- is properly handled in both the JVM and .NET cases.
+
+ and then VM_Target = No_VM
then
Error_Msg_N
("?foreign convention function& should not return " &
end if;
end if;
- -- For VMS, descriptor mechanisms for parameters are allowed only
- -- for imported/exported subprograms. Moreover, the NCA descriptor
- -- is not allowed for parameters of exported subprograms.
+ -- For VMS, descriptor mechanisms for parameters are allowed only for
+ -- imported/exported subprograms. Moreover, the NCA descriptor is not
+ -- allowed for parameters of exported subprograms.
if OpenVMS_On_Target then
if Is_Exported (E) then
Error_Msg_N
("pragma Inline_Always not allowed for dispatching subprograms", E);
end if;
+
+ -- Because of the implicit representation of inherited predefined
+ -- operators in the front-end, the overriding status of the operation
+ -- may be affected when a full view of a type is analyzed, and this is
+ -- not captured by the analysis of the corresponding type declaration.
+ -- Therefore the correctness of a not-overriding indicator must be
+ -- rechecked when the subprogram is frozen.
+
+ if Nkind (E) = N_Defining_Operator_Symbol
+ and then not Error_Posted (Parent (E))
+ then
+ Check_Overriding_Indicator (E, Empty, Is_Primitive (E));
+ end if;
end Freeze_Subprogram;
----------------------
return True;
end;
+ -- For the designated type of an access to subprogram, all types in
+ -- the profile must be fully defined.
+
+ elsif Ekind (T) = E_Subprogram_Type then
+ declare
+ F : Entity_Id;
+
+ begin
+ F := First_Formal (T);
+ while Present (F) loop
+ if not Is_Fully_Defined (Etype (F)) then
+ return False;
+ end if;
+
+ Next_Formal (F);
+ end loop;
+
+ return Is_Fully_Defined (Etype (T));
+ end;
+
else
return not Is_Private_Type (T)
or else Present (Full_View (Base_Type (T)));
-- involve secondary stack expansion.
else
- Dnam :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
+ Dnam := Make_Temporary (Loc, 'D');
Dbody :=
Make_Subprogram_Body (Loc,
end if;
-- We only give the warning for non-imported entities of a type for
- -- which a non-null base init proc is defined (or for access types which
- -- have implicit null initialization).
+ -- which a non-null base init proc is defined, or for objects of access
+ -- types with implicit null initialization, or when Normalize_Scalars
+ -- applies and the type is scalar or a string type (the latter being
+ -- tested for because predefined String types are initialized by inline
+ -- code rather than by an init_proc). Note that we do not give the
+ -- warning for Initialize_Scalars, since we suppressed initialization
+ -- in this case.
if Present (Expr)
- and then (Has_Non_Null_Base_Init_Proc (Typ)
- or else Is_Access_Type (Typ))
and then not Is_Imported (Ent)
+ and then (Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Access_Type (Typ)
+ or else (Normalize_Scalars
+ and then (Is_Scalar_Type (Typ)
+ or else Is_String_Type (Typ))))
then
if Nkind (Expr) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (Expr))
OSDN Git Service
