-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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 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. --
--- --
--- 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/>. --
+-- 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 COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
with Layout; use Layout;
+with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
procedure Freeze_And_Append
(Ent : Entity_Id;
- Loc : Source_Ptr;
+ N : Node_Id;
Result : in out List_Id);
-- Freezes Ent using Freeze_Entity, and appends the resulting list of
- -- nodes to Result, modifying Result from No_List if necessary.
+ -- nodes to Result, modifying Result from No_List if necessary. N has
+ -- the same usage as in Freeze_Entity.
procedure Freeze_Enumeration_Type (Typ : Entity_Id);
-- Freeze enumeration type. The Esize field is set as processing
procedure Process_Default_Expressions
(E : Entity_Id;
After : in out Node_Id);
- -- This procedure is called for each subprogram to complete processing
- -- of default expressions at the point where all types are known to be
- -- frozen. The expressions must be analyzed in full, to make sure that
- -- all error processing is done (they have only been pre-analyzed). If
- -- the expression is not an entity or literal, its analysis may generate
- -- code which must not be executed. In that case we build a function
- -- body to hold that code. This wrapper function serves no other purpose
- -- (it used to be called to evaluate the default, but now the default is
- -- inlined at each point of call).
+ -- This procedure is called for each subprogram to complete processing of
+ -- default expressions at the point where all types are known to be frozen.
+ -- The expressions must be analyzed in full, to make sure that all error
+ -- processing is done (they have only been pre-analyzed). If the expression
+ -- is not an entity or literal, its analysis may generate code which must
+ -- not be executed. In that case we build a function body to hold that
+ -- code. This wrapper function serves no other purpose (it used to be
+ -- called to evaluate the default, but now the default is inlined at each
+ -- point of call).
procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id);
- -- Typ is a record or array type that is being frozen. This routine
- -- sets the default component alignment from the scope stack values
- -- if the alignment is otherwise not specified.
+ -- Typ is a record or array type that is being frozen. This routine sets
+ -- the default component alignment from the scope stack values if the
+ -- alignment is otherwise not specified.
procedure Check_Debug_Info_Needed (T : Entity_Id);
-- As each entity is frozen, this routine is called to deal with the
-- subsidiary entities have the flag set as required.
procedure Undelay_Type (T : Entity_Id);
- -- T is a type of a component that we know to be an Itype.
- -- We don't want this to have a Freeze_Node, so ensure it doesn't.
- -- Do the same for any Full_View or Corresponding_Record_Type.
+ -- T is a type of a component that we know to be an Itype. We don't want
+ -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any
+ -- Full_View or Corresponding_Record_Type.
procedure Warn_Overlay
(Expr : Node_Id;
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 intrinsic 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. This is not done in the case
+ -- where the subprogram is an instantiation because the actual proper
+ -- body has not been built yet.
- 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
+ and then not Is_Generic_Instance (Old_S)
then
Set_Body_To_Inline (Decl, Old_S);
end if;
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 adjust accordingly.
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.
-
- -- 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.
-
- -- 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 (Expression (Decl))
- and then not Needs_Finalization (Typ)
- and then
- (not Has_Non_Null_Base_Init_Proc (Typ)
- or else Is_Imported (E)))
-
- or else
- (Present (Expression (Decl))
- and then Is_Scalar_Type (Typ))
-
- or else
- Is_Access_Type (Typ)
-
- or else
- (Is_Bit_Packed_Array (Typ)
- and then
- Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
- then
- null;
-
- -- 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.
- -- Actually the IP call has been moved to the freeze actions
- -- anyway, so maybe we can relax this restriction???
-
- else
+ if Needs_Constant_Address (Decl, Typ) then
Check_Constant_Address_Clause (Expr, E);
-- Has_Delayed_Freeze was set on E when the address clause was
end if;
end if;
- if not Error_Posted (Expr)
+ -- 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..
+
+ if Ignore_Rep_Clauses then
+ declare
+ Rep : Node_Id;
+
+ begin
+ Rep := First_Rep_Item (E);
+
+ if Rep = Addr then
+ Set_First_Rep_Item (E, Next_Rep_Item (Addr));
+
+ else
+ while Present (Rep)
+ and then Next_Rep_Item (Rep) /= Addr
+ loop
+ Rep := Next_Rep_Item (Rep);
+ end loop;
+ 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)));
+
+ elsif not Error_Posted (Expr)
and then not Needs_Finalization (Typ)
then
Warn_Overlay (Expr, Typ, Name (Addr));
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;
+ -- 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
- Set_Esize (T, S);
end if;
- -- Set sizes if not set already
-
- else
- if Unknown_Esize (T) then
- Set_Esize (T, S);
- end if;
+ -- Set size if not set already
- if Unknown_RM_Size (T) then
- Set_RM_Size (T, S);
- end if;
+ elsif Unknown_RM_Size (T) then
+ Set_RM_Size (T, S);
end if;
end Set_Small_Size;
return False;
-- A subtype of a variant record must not have non-static
- -- discriminanted components.
+ -- discriminated components.
elsif T /= Base_Type (T)
and then not Static_Discriminated_Components (T)
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)))
- and then Unknown_Esize (T)
+ No (Discriminant_Default_Value (First_Discriminant (T)))
+ and then Unknown_RM_Size (T)
then
return False;
end if;
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
end if;
Comp := First_Component (E);
-
while Present (Comp) loop
if not Is_Type (Comp)
and then (Strict_Alignment (Etype (Comp))
-- 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;
begin
Par := Parent (E);
- -- Array may be qualified, so find outer context.
+ -- Array may be qualified, so find outer context
if Nkind (Par) = N_Qualified_Expression then
Par := Parent (Par);
if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement)
and then Comes_From_Source (Par)
then
- Temp :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('T'));
-
+ Temp := Make_Temporary (Loc, 'T', E);
New_N :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
-- as they are generated.
procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is
- Loc : constant Source_Ptr := Sloc (After);
E : Entity_Id;
Decl : Node_Id;
-- 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;
End_Package_Scope (E);
+ if Is_Generic_Instance (E)
+ and then Has_Delayed_Freeze (E)
+ then
+ Set_Has_Delayed_Freeze (E, False);
+ Expand_N_Package_Declaration (Unit_Declaration_Node (E));
+ end if;
+
elsif Ekind (E) in Task_Kind
and then
(Nkind (Parent (E)) = N_Task_Type_Declaration
Subp : Entity_Id;
begin
- Prim := First_Elmt (Prim_List);
-
+ Prim := First_Elmt (Prim_List);
while Present (Prim) loop
Subp := Node (Prim);
if Comes_From_Source (Subp)
and then not Is_Frozen (Subp)
then
- Flist := Freeze_Entity (Subp, Loc);
+ Flist := Freeze_Entity (Subp, After);
Process_Flist;
end if;
end if;
if not Is_Frozen (E) then
- Flist := Freeze_Entity (E, Loc);
+ Flist := Freeze_Entity (E, After);
Process_Flist;
+
+ -- If already frozen, and there are delayed aspects, this is where
+ -- we do the visibility check for these aspects (see Sem_Ch13 spec
+ -- for a description of how we handle aspect visibility).
+
+ elsif Has_Delayed_Aspects (E) then
+ declare
+ Ritem : Node_Id;
+
+ begin
+ Ritem := First_Rep_Item (E);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Aspect_Specification
+ and then Entity (Ritem) = E
+ and then Is_Delayed_Aspect (Ritem)
+ then
+ Check_Aspect_At_End_Of_Declarations (Ritem);
+ end if;
+
+ Ritem := Next_Rep_Item (Ritem);
+ end loop;
+ end;
end if;
-- If an incomplete type is still not frozen, this may be a
-- premature freezing because of a body declaration that follows.
- -- Indicate where the freezing took place.
+ -- Indicate where the freezing took place. Freezing will happen
+ -- if the body comes from source, but not if it is internally
+ -- generated, for example as the body of a type invariant.
-- If the freezing is caused by the end of the current declarative
-- part, it is a Taft Amendment type, and there is no error.
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
+ -- The presence of a body freezes all entities previously
+ -- declared in the current list of declarations, but this
+ -- does not apply if the body does not come from source.
+ -- A type invariant is transformed into a subprogram body
+ -- which is placed at the end of the private part of the
+ -- current package, but this body does not freeze incomplete
+ -- types that may be declared in this private part.
+
+ 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))
+ and then
+ List_Containing (After) = List_Containing (Parent (E))
+ and then Comes_From_Source (Bod)
then
Error_Msg_Sloc := Sloc (Next (After));
Error_Msg_NE
-- 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
Decl := Unit_Declaration_Node (E);
if Nkind (Decl) = N_Subprogram_Renaming_Declaration then
- Build_And_Analyze_Renamed_Body (Decl, E, After);
+ if Error_Posted (Decl) then
+ Set_Has_Completion (E);
+ else
+ Build_And_Analyze_Renamed_Body (Decl, E, After);
+ end if;
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
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
end loop;
end;
+ -- We add finalization masters to access types whose designated types
+ -- require finalization. This is normally done when freezing the
+ -- type, but this misses recursive type definitions where the later
+ -- members of the recursion introduce controlled components (such as
+ -- can happen when incomplete types are involved), as well cases
+ -- where a component type is private and the controlled full type
+ -- occurs after the access type is frozen. Cases that don't need a
+ -- finalization master are generic formal types (the actual type will
+ -- have it) and types with Java and CIL conventions, since those are
+ -- used for API bindings. (Are there any other cases that should be
+ -- excluded here???)
+
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
- and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type
+ and then not Is_Generic_Type (E)
and then Needs_Finalization (Designated_Type (E))
- and then No (Associated_Final_Chain (E))
then
- Build_Final_List (Parent (E), E);
+ Build_Finalization_Master (E);
end if;
Next_Entity (E);
procedure Freeze_And_Append
(Ent : Entity_Id;
- Loc : Source_Ptr;
+ N : Node_Id;
Result : in out List_Id)
is
- L : constant List_Id := Freeze_Entity (Ent, Loc);
+ L : constant List_Id := Freeze_Entity (Ent, N);
begin
if Is_Non_Empty_List (L) then
if Result = No_List then
-------------------
procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
- Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N));
+ Freeze_Nodes : constant List_Id := Freeze_Entity (T, N);
begin
if Is_Non_Empty_List (Freeze_Nodes) then
Insert_Actions (N, Freeze_Nodes);
-- Freeze_Entity --
-------------------
- function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id is
+ function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is
+ Loc : constant Source_Ptr := Sloc (N);
Test_E : Entity_Id := E;
Comp : Entity_Id;
F_Node : Node_Id;
- Result : List_Id;
Indx : Node_Id;
Formal : Entity_Id;
Atype : Entity_Id;
+ Result : List_Id := No_List;
+ -- List of freezing actions, left at No_List if none
+
Has_Default_Initialization : Boolean := False;
-- This flag gets set to true for a variable with default initialization
+ procedure Add_To_Result (N : Node_Id);
+ -- N is a freezing action to be appended to the Result
+
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
-- Freeze each component, handle some representation clauses, and freeze
-- primitive operations if this is a tagged type.
+ -------------------
+ -- Add_To_Result --
+ -------------------
+
+ procedure Add_To_Result (N : Node_Id) is
+ begin
+ if No (Result) then
+ Result := New_List (N);
+ else
+ Append (N, Result);
+ end if;
+ end Add_To_Result;
+
----------------------------
-- After_Last_Declaration --
----------------------------
procedure Check_Current_Instance (Comp_Decl : Node_Id) is
- Rec_Type : constant Entity_Id :=
- Scope (Defining_Identifier (Comp_Decl));
-
- Decl : constant Node_Id := Parent (Rec_Type);
+ function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean;
+ -- Determine whether Typ is compatible with the rules for aliased
+ -- views of types as defined in RM 3.10 in the various dialects.
function Process (N : Node_Id) return Traverse_Result;
-- Process routine to apply check to given node
+ -----------------------------
+ -- Is_Aliased_View_Of_Type --
+ -----------------------------
+
+ function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is
+ Typ_Decl : constant Node_Id := Parent (Typ);
+
+ begin
+ -- Common case
+
+ if Nkind (Typ_Decl) = N_Full_Type_Declaration
+ and then Limited_Present (Type_Definition (Typ_Decl))
+ then
+ return True;
+
+ -- The following paragraphs describe what a legal aliased view of
+ -- a type is in the various dialects of Ada.
+
+ -- Ada 95
+
+ -- The current instance of a limited type, and a formal parameter
+ -- or generic formal object of a tagged type.
+
+ -- Ada 95 limited type
+ -- * Type with reserved word "limited"
+ -- * A protected or task type
+ -- * A composite type with limited component
+
+ elsif Ada_Version <= Ada_95 then
+ return Is_Limited_Type (Typ);
+
+ -- Ada 2005
+
+ -- The current instance of a limited tagged type, a protected
+ -- type, a task type, or a type that has the reserved word
+ -- "limited" in its full definition ... a formal parameter or
+ -- generic formal object of a tagged type.
+
+ -- Ada 2005 limited type
+ -- * Type with reserved word "limited", "synchronized", "task"
+ -- or "protected"
+ -- * A composite type with limited component
+ -- * A derived type whose parent is a non-interface limited type
+
+ elsif Ada_Version = Ada_2005 then
+ return
+ (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ))
+ or else
+ (Is_Derived_Type (Typ)
+ and then not Is_Interface (Etype (Typ))
+ and then Is_Limited_Type (Etype (Typ)));
+
+ -- Ada 2012 and beyond
+
+ -- The current instance of an immutably limited type ... a formal
+ -- parameter or generic formal object of a tagged type.
+
+ -- Ada 2012 limited type
+ -- * Type with reserved word "limited", "synchronized", "task"
+ -- or "protected"
+ -- * A composite type with limited component
+ -- * A derived type whose parent is a non-interface limited type
+ -- * An incomplete view
+
+ -- Ada 2012 immutably limited type
+ -- * Explicitly limited record type
+ -- * Record extension with "limited" present
+ -- * Non-formal limited private type that is either tagged
+ -- or has at least one access discriminant with a default
+ -- expression
+ -- * Task type, protected type or synchronized interface
+ -- * Type derived from immutably limited type
+
+ else
+ return
+ Is_Immutably_Limited_Type (Typ)
+ or else Is_Incomplete_Type (Typ);
+ end if;
+ end Is_Aliased_View_Of_Type;
+
-------------
-- Process --
-------------
procedure Traverse is new Traverse_Proc (Process);
- -- Start of processing for Check_Current_Instance
-
- begin
- -- In Ada95, the (imprecise) rule is that the current instance of a
- -- limited type is aliased. In Ada2005, limitedness must be explicit:
- -- either a tagged type, or a limited record.
+ -- Local variables
- if Is_Limited_Type (Rec_Type)
- and then (Ada_Version < Ada_05 or else Is_Tagged_Type (Rec_Type))
- then
- return;
+ Rec_Type : constant Entity_Id :=
+ Scope (Defining_Identifier (Comp_Decl));
- elsif Nkind (Decl) = N_Full_Type_Declaration
- and then Limited_Present (Type_Definition (Decl))
- then
- return;
+ -- Start of processing for Check_Current_Instance
- else
+ begin
+ if not Is_Aliased_View_Of_Type (Rec_Type) then
Traverse (Comp_Decl);
end if;
end Check_Current_Instance;
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
then
IR := Make_Itype_Reference (Sloc (Comp));
Set_Itype (IR, Desig);
-
- if No (Result) then
- Result := New_List (IR);
- else
- Append (IR, Result);
- end if;
+ Add_To_Result (IR);
end if;
elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type
-- Start of processing for Freeze_Record_Type
begin
- -- If this is a subtype of a controlled type, declared without a
- -- constraint, the _controller may not appear in the component list
- -- if the parent was not frozen at the point of subtype declaration.
- -- Inherit the _controller component now.
-
- if Rec /= Base_Type (Rec)
- and then Has_Controlled_Component (Rec)
- then
- if Nkind (Parent (Rec)) = N_Subtype_Declaration
- and then Is_Entity_Name (Subtype_Indication (Parent (Rec)))
- then
- Set_First_Entity (Rec, First_Entity (Base_Type (Rec)));
-
- -- If this is an internal type without a declaration, as for
- -- record component, the base type may not yet be frozen, and its
- -- controller has not been created. Add an explicit freeze node
- -- for the itype, so it will be frozen after the base type. This
- -- freeze node is used to communicate with the expander, in order
- -- to create the controller for the enclosing record, and it is
- -- deleted afterwards (see exp_ch3). It must not be created when
- -- expansion is off, because it might appear in the wrong context
- -- for the back end.
-
- elsif Is_Itype (Rec)
- and then Has_Delayed_Freeze (Base_Type (Rec))
- and then
- Nkind (Associated_Node_For_Itype (Rec)) =
- N_Component_Declaration
- and then Expander_Active
- then
- Ensure_Freeze_Node (Rec);
- end if;
- end if;
-
-- Freeze components and embedded subtypes
Comp := First_Entity (Rec);
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
Undelay_Type (Etype (Comp));
end if;
- Freeze_And_Append (Etype (Comp), Loc, Result);
+ Freeze_And_Append (Etype (Comp), N, Result);
-- Check for error of component clause given for variable
-- sized type. We have to delay this test till this point,
-- if it is variable length. We omit this test in a generic
-- context, it will be applied at instantiation time.
+ -- We also omit this test in CodePeer mode, since we do not
+ -- have sufficient info on size and representation clauses.
+
if Present (CC) then
Placed_Component := True;
if Inside_A_Generic then
null;
+ elsif CodePeer_Mode then
+ null;
+
elsif not
Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp)))
Component_Name (Component_Clause (Comp)));
end if;
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);
- Error_Msg_N
- ("\consider possibility of using "
- & "Ada 2005 mode here", 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));
-
- Set_Normalized_First_Bit
- (Comp,
- Component_Bit_Offset (Comp) mod
- System_Storage_Unit);
- end if;
- end;
- end if;
end;
end if;
- -- Gather data for possible Implicit_Packing later
+ -- 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.
if not Is_Scalar_Type (Etype (Comp)) then
All_Scalar_Components := False;
-- 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))
then
if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
- (Entity (Expression (Alloc)), Loc, Result);
+ (Entity (Expression (Alloc)), N, Result);
elsif
Nkind (Expression (Alloc)) = N_Subtype_Indication
then
Freeze_And_Append
(Entity (Subtype_Mark (Expression (Alloc))),
- Loc, Result);
+ N, Result);
end if;
elsif Is_Itype (Designated_Type (Etype (Comp))) then
else
Freeze_And_Append
- (Designated_Type (Etype (Comp)), Loc, Result);
+ (Designated_Type (Etype (Comp)), N, Result);
end if;
end if;
end;
then
Freeze_And_Append
(Designated_Type
- (Component_Type (Etype (Comp))), Loc, Result);
+ (Component_Type (Etype (Comp))), N, Result);
end if;
Prev := Comp;
Next_Entity (Comp);
end loop;
- -- Deal with pragma Bit_Order
+ -- Deal with Bit_Order aspect specifying a non-default 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)
- and then Convention (Rec) = Convention_Ada
- then
+ if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then
if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V)
or else
(not Has_Discriminants (Rec) and then Debug_Flag_Dot_R)
-- 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;
if Ekind (Rec) = E_Record_Type then
if Present (Corresponding_Remote_Type (Rec)) then
- Freeze_And_Append
- (Corresponding_Remote_Type (Rec), Loc, Result);
+ Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result);
end if;
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;
if Has_Unchecked_Union (Etype (Comp)) then
Set_Has_Unchecked_Union (Rec);
end if;
- if Has_Per_Object_Constraint (Comp) then
-
- -- Scan component declaration for likely misuses of current
- -- instance, either in a constraint or a default expression.
+ -- Scan component declaration for likely misuses of current
+ -- instance, either in a constraint or a default expression.
+ if Has_Per_Object_Constraint (Comp) then
Check_Current_Instance (Parent (Comp));
end if;
if Is_First_Subtype (Rec) then
Comp := First_Component (Rec);
-
while Present (Comp) loop
if Present (Component_Clause (Comp))
and then (Is_Fixed_Point_Type (Etype (Comp))
end;
end if;
- -- See if Implicit_Packing would work
+ -- 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)
- and then Esize (Rec) < Scalar_Component_Total_Esize
- and then Esize (Rec) >= Scalar_Component_Total_RM_Size
+
+ -- 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 RM_Size (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 RM_Size (Rec) >= Scalar_Component_Total_RM_Size
+
+ -- Never do implicit packing in CodePeer or Alfa modes since
+ -- we don't do any packing in these modes, since this generates
+ -- over-complex code that confuses static analysis, and in
+ -- general, neither CodePeer not GNATprove care about the
+ -- internal representation of objects.
+
+ and then not (CodePeer_Mode or Alfa_Mode)
then
-- If implicit packing enabled, do it
declare
Sz : constant Node_Id := Size_Clause (Rec);
begin
- Error_Msg_NE -- CODEFIX
+ Error_Msg_NE -- CODEFIX
("size given for& too small", Sz, Rec);
- Error_Msg_N -- CODEFIX
+ Error_Msg_N -- CODEFIX
("\use explicit pragma Pack "
& "or use pragma Implicit_Packing", Sz);
end;
elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then
return No_List;
+ -- AI05-0213: A formal incomplete type does not freeze the actual. In
+ -- the instance, the same applies to the subtype renaming the actual.
+
+ elsif Is_Private_Type (E)
+ and then Is_Generic_Actual_Type (E)
+ and then No (Full_View (Base_Type (E)))
+ and then Ada_Version >= Ada_2012
+ then
+ return No_List;
+
-- Do not freeze a global entity within an inner scope created during
-- expansion. A call to subprogram E within some internal procedure
-- (a stream attribute for example) might require freezing E, but the
and then Ekind (Test_E) /= E_Constant
then
declare
- S : Entity_Id := Current_Scope;
+ S : Entity_Id;
begin
+ S := Current_Scope;
while Present (S) loop
if Is_Overloadable (S) then
if Comes_From_Source (S)
and then Present (Scope (Test_E))
then
declare
- S : Entity_Id := Scope (Test_E);
+ S : Entity_Id;
begin
+ S := Scope (Test_E);
while Present (S) loop
if Is_Generic_Instance (S) then
exit;
end;
end if;
+ -- Deal with delayed aspect specifications. The analysis of the aspect
+ -- is required to be delayed to the freeze point, so we evaluate the
+ -- pragma or attribute definition clause in the tree at this point.
+
+ if Has_Delayed_Aspects (E) then
+ declare
+ Ritem : Node_Id;
+ Aitem : Node_Id;
+
+ begin
+ -- Look for aspect specification entries for this entity
+
+ Ritem := First_Rep_Item (E);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Aspect_Specification
+ and then Entity (Ritem) = E
+ and then Is_Delayed_Aspect (Ritem)
+ and then Scope (E) = Current_Scope
+ then
+ Aitem := Aspect_Rep_Item (Ritem);
+
+ -- Skip if this is an aspect with no corresponding pragma
+ -- or attribute definition node (such as Default_Value).
+
+ if Present (Aitem) then
+ Set_Parent (Aitem, Ritem);
+ Analyze (Aitem);
+ end if;
+ end if;
+
+ Next_Rep_Item (Ritem);
+ end loop;
+ end;
+ end if;
+
-- Here to freeze the entity
- Result := No_List;
Set_Is_Frozen (E);
-- Case of entity being frozen is other than a type
-- 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));
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))
+ and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E))
then
null;
end if;
Formal := First_Formal (E);
while Present (Formal) loop
F_Type := Etype (Formal);
- Freeze_And_Append (F_Type, Loc, Result);
+
+ -- AI05-0151 : incomplete types can appear in a profile.
+ -- By the time the entity is frozen, the full view must
+ -- be available, unless it is a limited view.
+
+ if Is_Incomplete_Type (F_Type)
+ and then Present (Full_View (F_Type))
+ then
+ F_Type := Full_View (F_Type);
+ Set_Etype (Formal, F_Type);
+ end if;
+
+ Freeze_And_Append (F_Type, N, Result);
if Is_Private_Type (F_Type)
and then Is_Private_Type (Base_Type (F_Type))
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
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
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;
if Is_Itype (Etype (Formal))
and then Ekind (F_Type) = E_Subprogram_Type
then
- Freeze_And_Append (F_Type, Loc, Result);
+ Freeze_And_Append (F_Type, N, Result);
end if;
end if;
-- Freeze return type
R_Type := Etype (E);
- Freeze_And_Append (R_Type, Loc, Result);
+
+ -- AI05-0151: the return type may have been incomplete
+ -- at the point of declaration.
+
+ if Ekind (R_Type) = E_Incomplete_Type
+ and then Present (Full_View (R_Type))
+ then
+ R_Type := Full_View (R_Type);
+ Set_Etype (E, R_Type);
+ end if;
+
+ Freeze_And_Append (R_Type, N, Result);
-- Check suspicious return type for C function
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;
- -- Give warning for suspicous return of a result of an
+ -- Give warning for suspicious return of a result of an
-- unconstrained array type in a foreign convention
-- function.
and then not Is_Constrained (R_Type)
-- Exclude imported routines, the warning does not
- -- belong on the import, but on the routine definition.
+ -- belong on the import, but rather on the routine
+ -- definition.
and then not Is_Imported (E)
-- Must freeze its parent first if it is a derived subprogram
if Present (Alias (E)) then
- Freeze_And_Append (Alias (E), Loc, Result);
+ Freeze_And_Append (Alias (E), N, Result);
end if;
-- We don't freeze internal subprograms, because we don't normally
if Present (Etype (E))
and then Ekind (E) /= E_Generic_Function
then
- Freeze_And_Append (Etype (E), Loc, Result);
+ Freeze_And_Append (Etype (E), N, Result);
end if;
-- Special processing for objects created by object declaration
-- 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
+ -- expansion of x'Class'Input where x is abstract) where we
-- legitimately generate an abstract object.
if Is_Abstract_Type (Etype (E))
Object_Definition (Parent (E)));
if Is_CPP_Class (Etype (E)) then
- Error_Msg_NE ("\} may need a cpp_constructor",
+ Error_Msg_NE
+ ("\} may need a cpp_constructor",
Object_Definition (Parent (E)), Etype (E));
end if;
end if;
((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)))
+ and then not Initialization_Suppressed (Etype (E)))
or else
(Needs_Simple_Initialization (Etype (E))
and then not Is_Internal (E)))
else
-- We used to check here that a full type must have preelaborable
-- initialization if it completes a private type specified with
- -- pragma Preelaborable_Intialization, but that missed cases where
+ -- pragma Preelaborable_Initialization, but that missed cases where
-- the types occur within a generic package, since the freezing
-- that occurs within a containing scope generally skips traversal
-- of a generic unit's declarations (those will be frozen within
-- nable and used in subsequent checks, so might as well try to
-- compute it.
+ -- In Ada 2012, Freeze_Entities is also used in the front end to
+ -- trigger the analysis of aspect expressions, so in this case we
+ -- want to continue the freezing process.
+
if Present (Scope (E))
and then Is_Generic_Unit (Scope (E))
+ and then not Has_Predicates (E)
then
Check_Compile_Time_Size (E);
return No_List;
-- action that causes stuff to be inherited).
if Present (Size_Clause (E))
- and then Known_Static_Esize (E)
+ and then Known_Static_RM_Size (E)
and then not Is_Packed (E)
and then not Has_Pragma_Pack (E)
and then Number_Dimensions (E) = 1
and then not Has_Component_Size_Clause (E)
- and then Known_Static_Esize (Ctyp)
+ and then Known_Static_RM_Size (Ctyp)
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 or Alfa_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
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;
end if;
-- If ancestor subtype present, freeze that first. Note that this
- -- will also get the base type frozen.
+ -- will also get the base type frozen. Need RM reference ???
Atype := Ancestor_Subtype (E);
if Present (Atype) then
- Freeze_And_Append (Atype, Loc, Result);
+ Freeze_And_Append (Atype, N, Result);
- -- Otherwise freeze the base type of the entity before freezing
- -- the entity itself (RM 13.14(15)).
+ -- No ancestor subtype present
- elsif E /= Base_Type (E) then
- Freeze_And_Append (Base_Type (E), Loc, Result);
+ else
+ -- See if we have a nearest ancestor that has a predicate.
+ -- That catches the case of derived type with a predicate.
+ -- Need RM reference here ???
+
+ Atype := Nearest_Ancestor (E);
+
+ if Present (Atype) and then Has_Predicates (Atype) then
+ Freeze_And_Append (Atype, N, Result);
+ end if;
+
+ -- Freeze base type before freezing the entity (RM 13.14(15))
+
+ if E /= Base_Type (E) then
+ Freeze_And_Append (Base_Type (E), N, Result);
+ end if;
end if;
-- For a derived type, freeze its parent type first (RM 13.14(15))
elsif Is_Derived_Type (E) then
- Freeze_And_Append (Etype (E), Loc, Result);
- Freeze_And_Append (First_Subtype (Etype (E)), Loc, Result);
+ Freeze_And_Append (Etype (E), N, Result);
+ Freeze_And_Append (First_Subtype (Etype (E)), N, Result);
end if;
-- For array type, freeze index types and component type first
if Is_Array_Type (E) then
declare
- Ctyp : constant Entity_Id := Component_Type (E);
+ FS : constant Entity_Id := First_Subtype (E);
+ Ctyp : constant Entity_Id := Component_Type (E);
+ Clause : Entity_Id;
Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration type
-- with a non-standard representation.
begin
- Freeze_And_Append (Ctyp, Loc, Result);
+ Freeze_And_Append (Ctyp, N, Result);
Indx := First_Index (E);
while Present (Indx) loop
- Freeze_And_Append (Etype (Indx), Loc, Result);
+ Freeze_And_Append (Etype (Indx), N, Result);
if Is_Enumeration_Type (Etype (Indx))
and then Has_Non_Standard_Rep (Etype (Indx))
begin
if (Is_Packed (E) or else Has_Pragma_Pack (E))
- and then not Has_Atomic_Components (E)
and then Known_Static_RM_Size (Ctyp)
+ and then not Has_Component_Size_Clause (E)
then
Csiz := UI_Max (RM_Size (Ctyp), 1);
if Present (Comp_Size_C)
and then Has_Pragma_Pack (Ent)
+ and then Warn_On_Redundant_Constructs
then
Error_Msg_Sloc := Sloc (Comp_Size_C);
Error_Msg_NE
Error_Msg_N
("\?explicit component size given#!",
Pack_Pragma);
+ Set_Is_Packed (Base_Type (Ent), False);
+ Set_Is_Bit_Packed_Array (Base_Type (Ent), False);
end if;
-- Set component size if not already set by a
-- a representation characteristic, and this
-- request may be ignored.
- Set_Is_Packed (Base_Type (E), False);
+ Set_Is_Packed (Base_Type (E), False);
+ Set_Is_Bit_Packed_Array (Base_Type (E), False);
- -- In all other cases, packing is indeed needed
+ if Known_Static_Esize (Component_Type (E))
+ and then Esize (Component_Type (E)) = Csiz
+ then
+ Set_Has_Non_Standard_Rep
+ (Base_Type (E), False);
+ end if;
+
+ -- In all other cases, packing is indeed needed
else
- Set_Has_Non_Standard_Rep (Base_Type (E));
- Set_Is_Bit_Packed_Array (Base_Type (E));
- Set_Is_Packed (Base_Type (E));
+ Set_Has_Non_Standard_Rep (Base_Type (E), True);
+ Set_Is_Bit_Packed_Array (Base_Type (E), True);
+ Set_Is_Packed (Base_Type (E), True);
end if;
end;
end if;
end;
+ -- Check for Atomic_Components or Aliased with unsuitable
+ -- packing or explicit component size clause given.
+
+ if (Has_Atomic_Components (E)
+ or else Has_Aliased_Components (E))
+ and then (Has_Component_Size_Clause (E)
+ or else Is_Packed (E))
+ then
+ Alias_Atomic_Check : declare
+
+ procedure Complain_CS (T : String);
+ -- Outputs error messages for incorrect CS clause or
+ -- pragma Pack for aliased or atomic components (T is
+ -- "aliased" or "atomic");
+
+ -----------------
+ -- Complain_CS --
+ -----------------
+
+ procedure Complain_CS (T : String) is
+ begin
+ if Has_Component_Size_Clause (E) then
+ Clause :=
+ Get_Attribute_Definition_Clause
+ (FS, Attribute_Component_Size);
+
+ if Known_Static_Esize (Ctyp) then
+ Error_Msg_N
+ ("incorrect component size for "
+ & T & " components", Clause);
+ Error_Msg_Uint_1 := Esize (Ctyp);
+ Error_Msg_N
+ ("\only allowed value is^", Clause);
+
+ else
+ Error_Msg_N
+ ("component size cannot be given for "
+ & T & " components", Clause);
+ end if;
+
+ else
+ Error_Msg_N
+ ("cannot pack " & T & " components",
+ Get_Rep_Pragma (FS, Name_Pack));
+ end if;
+
+ return;
+ end Complain_CS;
+
+ -- Start of processing for Alias_Atomic_Check
+
+ begin
+
+ -- If object size of component type isn't known, we
+ -- cannot be sure so we defer to the back end.
+
+ if not Known_Static_Esize (Ctyp) then
+ null;
+
+ -- Case where component size has no effect. First
+ -- check for object size of component type multiple
+ -- of the storage unit size.
+
+ elsif Esize (Ctyp) mod System_Storage_Unit = 0
+
+ -- OK in both packing case and component size case
+ -- if RM size is known and static and the same as
+ -- the object size.
+
+ and then
+ ((Known_Static_RM_Size (Ctyp)
+ and then Esize (Ctyp) = RM_Size (Ctyp))
+
+ -- Or if we have an explicit component size
+ -- clause and the component size and object size
+ -- are equal.
+
+ or else
+ (Has_Component_Size_Clause (E)
+ and then Component_Size (E) = Esize (Ctyp)))
+ then
+ null;
+
+ elsif Has_Aliased_Components (E)
+ or else Is_Aliased (Ctyp)
+ then
+ Complain_CS ("aliased");
+
+ elsif Has_Atomic_Components (E)
+ or else Is_Atomic (Ctyp)
+ then
+ Complain_CS ("atomic");
+ end if;
+ end Alias_Atomic_Check;
+ end if;
+
+ -- Warn for case of atomic type
+
+ Clause := Get_Rep_Pragma (FS, Name_Atomic);
+
+ if Present (Clause)
+ and then not Addressable (Component_Size (FS))
+ then
+ Error_Msg_NE
+ ("non-atomic components of type& may not be "
+ & "accessible by separate tasks?", Clause, E);
+
+ if Has_Component_Size_Clause (E) then
+ Error_Msg_Sloc :=
+ Sloc
+ (Get_Attribute_Definition_Clause
+ (FS, Attribute_Component_Size));
+ Error_Msg_N
+ ("\because of component size clause#?",
+ Clause);
+
+ elsif Has_Pragma_Pack (E) then
+ Error_Msg_Sloc :=
+ Sloc (Get_Rep_Pragma (FS, Name_Pack));
+ Error_Msg_N
+ ("\because of pragma Pack#?", Clause);
+ end if;
+ end if;
+
-- Processing that is done only for subtypes
else
-- 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;
end if;
- -- If any of the index types was an enumeration type with
- -- a non-standard rep clause, then we indicate that the
- -- array type is always packed (even if it is not bit packed).
+ -- If any of the index types was an enumeration type with a
+ -- non-standard rep clause, then we indicate that the array
+ -- type is always packed (even if it is not bit packed).
if Non_Standard_Enum then
Set_Has_Non_Standard_Rep (Base_Type (E));
and then Ekind (E) /= E_String_Literal_Subtype
then
Create_Packed_Array_Type (E);
- Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
+ Freeze_And_Append (Packed_Array_Type (E), N, Result);
-- Size information of packed array type is copied to the
-- array type, since this is really the representation. But
-- frozen as well (RM 13.14(15))
elsif Is_Class_Wide_Type (E) then
- Freeze_And_Append (Root_Type (E), Loc, Result);
+ Freeze_And_Append (Root_Type (E), N, Result);
-- If the base type of the class-wide type is still incomplete,
-- the class-wide remains unfrozen as well. This is legal when
begin
Set_Itype (Ref, E);
- if No (Result) then
- Result := New_List (Ref);
- else
- Append (Ref, Result);
- end if;
+ Add_To_Result (Ref);
end;
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))
then
- Freeze_And_Append (Equivalent_Type (E), Loc, Result);
+ Freeze_And_Append (Equivalent_Type (E), N, Result);
end if;
-- For a record (sub)type, freeze all the component types (RM
elsif Is_Concurrent_Type (E) then
if Present (Corresponding_Record_Type (E)) then
Freeze_And_Append
- (Corresponding_Record_Type (E), Loc, Result);
+ (Corresponding_Record_Type (E), N, Result);
end if;
Comp := First_Entity (E);
while Present (Comp) loop
if Is_Type (Comp) then
- Freeze_And_Append (Comp, Loc, Result);
+ Freeze_And_Append (Comp, N, Result);
elsif (Ekind (Comp)) /= E_Function then
if Is_Itype (Etype (Comp))
Undelay_Type (Etype (Comp));
end if;
- Freeze_And_Append (Etype (Comp), Loc, Result);
+ Freeze_And_Append (Etype (Comp), N, Result);
end if;
Next_Entity (Comp);
-- package Pkg is
-- type T is tagged private;
-- type DT is new T with private;
- -- procedure Prim (X : in out T; Y : in out DT'class);
+ -- procedure Prim (X : in out T; Y : in out DT'Class);
-- private
-- type T is tagged null record;
-- Obj : T;
-- processing is required
if Is_Frozen (Full_View (E)) then
-
Set_Has_Delayed_Freeze (E, False);
Set_Freeze_Node (E, Empty);
Check_Debug_Info_Needed (E);
and then Present (Underlying_Full_View (Full))
then
Freeze_And_Append
- (Underlying_Full_View (Full), Loc, Result);
+ (Underlying_Full_View (Full), N, Result);
end if;
- Freeze_And_Append (Full, Loc, Result);
+ Freeze_And_Append (Full, N, Result);
if Has_Delayed_Freeze (E) then
F_Node := Freeze_Node (Full);
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)))
then
if Is_Tagged_Type (Etype (Formal)) then
null;
- else
+
+ -- AI05-151: Incomplete types are allowed in access to
+ -- subprogram specifications.
+
+ elsif Ada_Version < Ada_2012 then
Error_Msg_NE
("invalid use of incomplete type&", E, Etype (Formal));
end if;
end if;
- Freeze_And_Append (Etype (Formal), Loc, Result);
+ Freeze_And_Append (Etype (Formal), N, Result);
Next_Formal (Formal);
end loop;
elsif Is_Access_Protected_Subprogram_Type (E) then
if Present (Equivalent_Type (E)) then
- Freeze_And_Append (Equivalent_Type (E), Loc, Result);
+ Freeze_And_Append (Equivalent_Type (E), N, Result);
end if;
end if;
-- these till the freeze-point since we need the small and range
-- values. We only do these checks for base types
- if Is_Ordinary_Fixed_Point_Type (E)
- and then E = Base_Type (E)
- then
+ if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then
if Small_Value (E) < Ureal_2_M_80 then
Error_Msg_Name_1 := Name_Small;
Error_Msg_N
elsif Is_Integer_Type (E) then
Adjust_Esize_For_Alignment (E);
- if Is_Modular_Integer_Type (E) then
+ 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
+ -- If a pragma Default_Storage_Pool applies, and this type has no
+ -- Storage_Pool or Storage_Size clause (which must have occurred
+ -- before the freezing point), then use the default. This applies
+ -- only to base types.
+
+ if Present (Default_Pool)
+ and then Is_Base_Type (E)
+ and then not Has_Storage_Size_Clause (E)
+ and then No (Associated_Storage_Pool (E))
+ then
+ -- Case of pragma Default_Storage_Pool (null)
+
+ if Nkind (Default_Pool) = N_Null then
+ Set_No_Pool_Assigned (E);
+
+ -- Case of pragma Default_Storage_Pool (storage_pool_NAME)
+
+ else
+ Set_Associated_Storage_Pool (E, Entity (Default_Pool));
+ end if;
+ end if;
+
-- Check restriction for standard storage pool
if No (Associated_Storage_Pool (E)) then
-- error in Ada 2005 if there is no pool (see AI-366).
if Is_Pure_Unit_Access_Type (E)
- and then (Ada_Version < Ada_05
+ and then (Ada_Version < Ada_2005
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
+ if Ada_Version >= Ada_2005 then
Error_Msg_N
("\would be legal if Storage_Size of 0 given?", E);
declare
Prim_List : constant Elist_Id := Primitive_Operations (E);
Prim : Elmt_Id;
+
begin
Prim := First_Elmt (Prim_List);
while Present (Prim) loop
end loop;
end;
end if;
+
+ -- If the type is a simple storage pool type, then this is where
+ -- we attempt to locate and validate its Allocate, Deallocate, and
+ -- Storage_Size operations (the first is required, and the latter
+ -- two are optional). We also verify that the full type for a
+ -- private type is allowed to be a simple storage pool type.
+
+ if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type))
+ and then (Is_Base_Type (E) or else Has_Private_Declaration (E))
+ then
+ -- If the type is marked Has_Private_Declaration, then this is
+ -- a full type for a private type that was specified with the
+ -- pragma Simple_Storage_Pool_Type, and here we ensure that the
+ -- pragma is allowed for the full type (for example, it can't
+ -- be an array type, or a nonlimited record type).
+
+ if Has_Private_Declaration (E) then
+ if (not Is_Record_Type (E)
+ or else not Is_Immutably_Limited_Type (E))
+ and then not Is_Private_Type (E)
+ then
+ Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type;
+ Error_Msg_N
+ ("pragma% can only apply to full type that is an " &
+ "explicitly limited type", E);
+ end if;
+ end if;
+
+ Validate_Simple_Pool_Ops : declare
+ Pool_Type : Entity_Id renames E;
+ Address_Type : constant Entity_Id := RTE (RE_Address);
+ Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count);
+
+ procedure Validate_Simple_Pool_Op_Formal
+ (Pool_Op : Entity_Id;
+ Pool_Op_Formal : in out Entity_Id;
+ Expected_Mode : Formal_Kind;
+ Expected_Type : Entity_Id;
+ Formal_Name : String;
+ OK_Formal : in out Boolean);
+ -- Validate one formal Pool_Op_Formal of the candidate pool
+ -- operation Pool_Op. The formal must be of Expected_Type
+ -- and have mode Expected_Mode. OK_Formal will be set to
+ -- False if the formal doesn't match. If OK_Formal is False
+ -- on entry, then the formal will effectively be ignored
+ -- (because validation of the pool op has already failed).
+ -- Upon return, Pool_Op_Formal will be updated to the next
+ -- formal, if any.
+
+ procedure Validate_Simple_Pool_Operation (Op_Name : Name_Id);
+ -- Search for and validate a simple pool operation with the
+ -- name Op_Name. If the name is Allocate, then there must be
+ -- exactly one such primitive operation for the simple pool
+ -- type. If the name is Deallocate or Storage_Size, then
+ -- there can be at most one such primitive operation. The
+ -- profile of the located primitive must conform to what
+ -- is expected for each operation.
+
+ ------------------------------------
+ -- Validate_Simple_Pool_Op_Formal --
+ ------------------------------------
+
+ procedure Validate_Simple_Pool_Op_Formal
+ (Pool_Op : Entity_Id;
+ Pool_Op_Formal : in out Entity_Id;
+ Expected_Mode : Formal_Kind;
+ Expected_Type : Entity_Id;
+ Formal_Name : String;
+ OK_Formal : in out Boolean)
+ is
+ begin
+ -- If OK_Formal is False on entry, then simply ignore
+ -- the formal, because an earlier formal has already
+ -- been flagged.
+
+ if not OK_Formal then
+ return;
+
+ -- If no formal is passed in, then issue an error for a
+ -- missing formal.
+
+ elsif not Present (Pool_Op_Formal) then
+ Error_Msg_NE
+ ("simple storage pool op missing formal " &
+ Formal_Name & " of type&", Pool_Op, Expected_Type);
+ OK_Formal := False;
+
+ return;
+ end if;
+
+ if Etype (Pool_Op_Formal) /= Expected_Type then
+
+ -- If the pool type was expected for this formal, then
+ -- this will not be considered a candidate operation
+ -- for the simple pool, so we unset OK_Formal so that
+ -- the op and any later formals will be ignored.
+
+ if Expected_Type = Pool_Type then
+ OK_Formal := False;
+
+ return;
+
+ else
+ Error_Msg_NE
+ ("wrong type for formal " & Formal_Name &
+ " of simple storage pool op; expected type&",
+ Pool_Op_Formal, Expected_Type);
+ end if;
+ end if;
+
+ -- Issue error if formal's mode is not the expected one
+
+ if Ekind (Pool_Op_Formal) /= Expected_Mode then
+ Error_Msg_N
+ ("wrong mode for formal of simple storage pool op",
+ Pool_Op_Formal);
+ end if;
+
+ -- Advance to the next formal
+
+ Next_Formal (Pool_Op_Formal);
+ end Validate_Simple_Pool_Op_Formal;
+
+ ------------------------------------
+ -- Validate_Simple_Pool_Operation --
+ ------------------------------------
+
+ procedure Validate_Simple_Pool_Operation
+ (Op_Name : Name_Id)
+ is
+ Op : Entity_Id;
+ Found_Op : Entity_Id := Empty;
+ Formal : Entity_Id;
+ Is_OK : Boolean;
+
+ begin
+ pragma Assert
+ (Op_Name = Name_Allocate
+ or else Op_Name = Name_Deallocate
+ or else Op_Name = Name_Storage_Size);
+
+ Error_Msg_Name_1 := Op_Name;
+
+ -- For each homonym declared immediately in the scope
+ -- of the simple storage pool type, determine whether
+ -- the homonym is an operation of the pool type, and,
+ -- if so, check that its profile is as expected for
+ -- a simple pool operation of that name.
+
+ Op := Get_Name_Entity_Id (Op_Name);
+ while Present (Op) loop
+ if Ekind_In (Op, E_Function, E_Procedure)
+ and then Scope (Op) = Current_Scope
+ then
+ Formal := First_Entity (Op);
+
+ Is_OK := True;
+
+ -- The first parameter must be of the pool type
+ -- in order for the operation to qualify.
+
+ if Op_Name = Name_Storage_Size then
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Parameter, Pool_Type,
+ "Pool", Is_OK);
+ else
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Out_Parameter, Pool_Type,
+ "Pool", Is_OK);
+ end if;
+
+ -- If another operation with this name has already
+ -- been located for the type, then flag an error,
+ -- since we only allow the type to have a single
+ -- such primitive.
+
+ if Present (Found_Op) and then Is_OK then
+ Error_Msg_NE
+ ("only one % operation allowed for " &
+ "simple storage pool type&", Op, Pool_Type);
+ end if;
+
+ -- In the case of Allocate and Deallocate, a formal
+ -- of type System.Address is required.
+
+ if Op_Name = Name_Allocate then
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_Out_Parameter,
+ Address_Type, "Storage_Address", Is_OK);
+ elsif Op_Name = Name_Deallocate then
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Parameter,
+ Address_Type, "Storage_Address", Is_OK);
+ end if;
+
+ -- In the case of Allocate and Deallocate, formals
+ -- of type Storage_Count are required as the third
+ -- and fourth parameters.
+
+ if Op_Name /= Name_Storage_Size then
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Parameter,
+ Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK);
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Parameter,
+ Stg_Cnt_Type, "Alignment", Is_OK);
+ end if;
+
+ -- If no mismatched formals have been found (Is_OK)
+ -- and no excess formals are present, then this
+ -- operation has been validated, so record it.
+
+ if not Present (Formal) and then Is_OK then
+ Found_Op := Op;
+ end if;
+ end if;
+
+ Op := Homonym (Op);
+ end loop;
+
+ -- There must be a valid Allocate operation for the type,
+ -- so issue an error if none was found.
+
+ if Op_Name = Name_Allocate
+ and then not Present (Found_Op)
+ then
+ Error_Msg_N ("missing % operation for simple " &
+ "storage pool type", Pool_Type);
+
+ elsif Present (Found_Op) then
+
+ -- Simple pool operations can't be abstract
+
+ if Is_Abstract_Subprogram (Found_Op) then
+ Error_Msg_N
+ ("simple storage pool operation must not be " &
+ "abstract", Found_Op);
+ end if;
+
+ -- The Storage_Size operation must be a function with
+ -- Storage_Count as its result type.
+
+ if Op_Name = Name_Storage_Size then
+ if Ekind (Found_Op) = E_Procedure then
+ Error_Msg_N
+ ("% operation must be a function", Found_Op);
+
+ elsif Etype (Found_Op) /= Stg_Cnt_Type then
+ Error_Msg_NE
+ ("wrong result type for%, expected type&",
+ Found_Op, Stg_Cnt_Type);
+ end if;
+
+ -- Allocate and Deallocate must be procedures
+
+ elsif Ekind (Found_Op) = E_Function then
+ Error_Msg_N
+ ("% operation must be a procedure", Found_Op);
+ end if;
+ end if;
+ end Validate_Simple_Pool_Operation;
+
+ -- Start of processing for Validate_Simple_Pool_Ops
+
+ begin
+ Validate_Simple_Pool_Operation (Name_Allocate);
+ Validate_Simple_Pool_Operation (Name_Deallocate);
+ Validate_Simple_Pool_Operation (Name_Storage_Size);
+ end Validate_Simple_Pool_Ops;
+ end if;
end if;
-- Now that all types from which E may depend are frozen, see if the
end if;
end if;
- -- Remaining process is to set/verify the representation information,
- -- in particular the size and alignment values. This processing is
- -- not required for generic types, since generic types do not play
- -- any part in code generation, and so the size and alignment values
- -- for such types are irrelevant.
+ -- Now we set/verify the representation information, in particular
+ -- the size and alignment values. This processing is not required for
+ -- generic types, since generic types do not play any part in code
+ -- generation, and so the size and alignment values for such types
+ -- are irrelevant. Ditto for types declared within a generic unit,
+ -- which may have components that depend on generic parameters, and
+ -- that will be recreated in an instance.
- if Is_Generic_Type (E) then
- return Result;
+ if Inside_A_Generic then
+ null;
-- Otherwise we call the layout procedure
Layout_Type (E);
end if;
+ -- If this is an access to subprogram whose designated type is itself
+ -- a subprogram type, the return type of this anonymous subprogram
+ -- type must be decorated as well.
+
+ if Ekind (E) = E_Anonymous_Access_Subprogram_Type
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type
+ then
+ Layout_Type (Etype (Designated_Type (E)));
+ end if;
+
+ -- If the type has a Defaut_Value/Default_Component_Value aspect,
+ -- this is where we analye the expression (after the type is frozen,
+ -- since in the case of Default_Value, we are analyzing with the
+ -- type itself, and we treat Default_Component_Value similarly for
+ -- the sake of uniformity.
+
+ if Is_First_Subtype (E) and then Has_Default_Aspect (E) then
+ declare
+ Nam : Name_Id;
+ Exp : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ if Is_Scalar_Type (E) then
+ Nam := Name_Default_Value;
+ Typ := E;
+ Exp := Default_Aspect_Value (Typ);
+ else
+ Nam := Name_Default_Component_Value;
+ Typ := Component_Type (E);
+ Exp := Default_Aspect_Component_Value (E);
+ end if;
+
+ Analyze_And_Resolve (Exp, Typ);
+
+ if Etype (Exp) /= Any_Type then
+ if not Is_Static_Expression (Exp) then
+ Error_Msg_Name_1 := Nam;
+ Flag_Non_Static_Expr
+ ("aspect% requires static expression", Exp);
+ end if;
+ end if;
+ end;
+ end if;
+
-- End of freeze processing for type entities
end if;
end if;
Set_Entity (F_Node, E);
-
- if Result = No_List then
- Result := New_List (F_Node);
- else
- Append (F_Node, Result);
- end if;
+ Add_To_Result (F_Node);
-- A final pass over record types with discriminants. If the type
-- has an incomplete declaration, there may be constrained access
begin
Comp := First_Component (E);
-
while Present (Comp) loop
Typ := Etype (Comp);
-- since obviously the first subtype depends on its own base type.
if Is_Type (E) then
- Freeze_And_Append (First_Subtype (E), Loc, Result);
+ Freeze_And_Append (First_Subtype (E), N, Result);
-- If we just froze a tagged non-class wide record, then freeze the
-- corresponding class-wide type. This must be done after the tagged
and then not Is_Class_Wide_Type (E)
and then Present (Class_Wide_Type (E))
then
- Freeze_And_Append (Class_Wide_Type (E), Loc, Result);
+ Freeze_And_Append (Class_Wide_Type (E), N, Result);
end if;
end if;
-- subprogram in main unit, generate descriptor if we are in
-- Propagate_Exceptions mode.
+ -- This is very odd code, it makes a null result, why ???
+
elsif Propagate_Exceptions
and then Is_Imported (E)
and then not Is_Intrinsic_Subprogram (E)
-- 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.
+ -- type has no size clause either. Treat other foreign conventions
+ -- in the same way, and also make sure alignment is set right.
if Has_Foreign_Convention (Typ)
and then not Has_Size_Clause (Typ)
and then Esize (Typ) < Standard_Integer_Size
then
Init_Esize (Typ, Standard_Integer_Size);
+ Set_Alignment (Typ, Alignment (Standard_Integer));
else
-- If the enumeration type interfaces to C, and it has a size clause
-- If expression is non-static, then it does not freeze in a default
-- expression, see section "Handling of Default Expressions" in the
- -- spec of package Sem for further details. Note that we have to
- -- make sure that we actually have a real expression (if we have
- -- a subtype indication, we can't test Is_Static_Expression!)
+ -- spec of package Sem for further details. Note that we have to make
+ -- sure that we actually have a real expression (if we have a subtype
+ -- indication, we can't test Is_Static_Expression!) However, we exclude
+ -- the case of the prefix of an attribute of a static scalar subtype
+ -- from this early return, because static subtype attributes should
+ -- always cause freezing, even in default expressions, but the attribute
+ -- may not have been marked as static yet (because in Resolve_Attribute,
+ -- the call to Eval_Attribute follows the call of Freeze_Expression on
+ -- the prefix).
if In_Spec_Exp
and then Nkind (N) in N_Subexpr
and then not Is_Static_Expression (N)
+ and then (Nkind (Parent (N)) /= N_Attribute_Reference
+ or else not (Is_Entity_Name (N)
+ and then Is_Type (Entity (N))
+ and then Is_Static_Subtype (Entity (N))))
then
return;
end if;
-- 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.
+ -- the proper actuals. This only applies to Ada subprograms, not to
+ -- imported ones.
Desig_Typ := Empty;
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;
-- exiting from the loop when it is appropriate to insert the freeze
-- node before the current node P.
- -- Also checks som special exceptions to the freezing rules. These cases
- -- result in a direct return, bypassing the freeze action.
+ -- Also checks some special exceptions to the freezing rules. These
+ -- cases result in a direct return, bypassing the freeze action.
P := N;
loop
-- is a statement or declaration and we can insert the freeze node
-- before it.
- when N_Package_Specification |
+ when N_Block_Statement |
+ N_Entry_Body |
N_Package_Body |
- N_Subprogram_Body |
- N_Task_Body |
+ N_Package_Specification |
N_Protected_Body |
- N_Entry_Body |
- N_Block_Statement => exit;
+ N_Subprogram_Body |
+ N_Task_Body => exit;
-- The expander is allowed to define types in any statements list,
-- so any of the following parent nodes also mark a freezing point
-- if the actual node is in a list of statements or declarations.
- when N_Exception_Handler |
- N_If_Statement |
- N_Elsif_Part |
+ when N_Abortable_Part |
+ N_Accept_Alternative |
+ N_And_Then |
N_Case_Statement_Alternative |
N_Compilation_Unit_Aux |
- N_Selective_Accept |
- N_Accept_Alternative |
- N_Delay_Alternative |
N_Conditional_Entry_Call |
+ N_Delay_Alternative |
+ N_Elsif_Part |
N_Entry_Call_Alternative |
- N_Triggering_Alternative |
- N_Abortable_Part |
- N_Freeze_Entity =>
+ N_Exception_Handler |
+ N_Extended_Return_Statement |
+ N_Freeze_Entity |
+ N_If_Statement |
+ N_Or_Else |
+ N_Selective_Accept |
+ N_Triggering_Alternative =>
exit when Is_List_Member (P);
or else Ekind (Current_Scope) = E_Void
then
declare
- Loc : constant Source_Ptr := Sloc (Current_Scope);
- Freeze_Nodes : List_Id := No_List;
- Pos : Int := Scope_Stack.Last;
+ N : constant Node_Id := Current_Scope;
+ Freeze_Nodes : List_Id := No_List;
+ Pos : Int := Scope_Stack.Last;
begin
if Present (Desig_Typ) then
- Freeze_And_Append (Desig_Typ, Loc, Freeze_Nodes);
+ Freeze_And_Append (Desig_Typ, N, Freeze_Nodes);
end if;
if Present (Typ) then
- Freeze_And_Append (Typ, Loc, Freeze_Nodes);
+ Freeze_And_Append (Typ, N, Freeze_Nodes);
end if;
if Present (Nam) then
- Freeze_And_Append (Nam, Loc, Freeze_Nodes);
+ Freeze_And_Append (Nam, N, Freeze_Nodes);
end if;
-- The current scope may be that of a constrained component of
-- an enclosing record declaration, which is above the current
-- scope in the scope stack.
+ -- If the expression is within a top-level pragma, as for a pre-
+ -- condition on a library-level subprogram, nothing to do.
- if Is_Record_Type (Scope (Current_Scope)) then
+ if not Is_Compilation_Unit (Current_Scope)
+ and then Is_Record_Type (Scope (Current_Scope))
+ then
Pos := Pos - 1;
end if;
if Is_Non_Empty_List (Freeze_Nodes) then
if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then
Scope_Stack.Table (Pos).Pending_Freeze_Actions :=
- Freeze_Nodes;
+ 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;
-- natural boundary of size.
elsif Size_Incl_EP /= Size_Excl_EP
- and then
- (Size_Excl_EP = 8 or else
- Size_Excl_EP = 16 or else
- Size_Excl_EP = 32 or else
- Size_Excl_EP = 64)
+ and then Addressable (Size_Excl_EP)
then
Actual_Size := Size_Excl_EP;
Actual_Lo := Loval_Excl_EP;
begin
Set_Has_Delayed_Freeze (T);
- L := Freeze_Entity (T, Sloc (N));
+ L := Freeze_Entity (T, N);
if Is_Non_Empty_List (L) then
Insert_Actions (N, L);
end if;
F := First_Formal (Designated_Type (Typ));
-
while Present (F) loop
Ensure_Type_Is_SA (Etype (F));
Next_Formal (F);
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).
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???)
+ -- 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.
+ -- 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
begin
Comp := First_Component (T);
-
while Present (Comp) loop
if not Is_Fully_Defined (Etype (Comp)) then
return False;
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,
Declarations => New_List (
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('T')),
- Object_Definition =>
- New_Occurrence_Of (Etype (Formal), Loc),
- Expression => New_Copy_Tree (Dcopy))),
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Formal), Loc),
+ Expression => New_Copy_Tree (Dcopy))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List));
+ Statements => Empty_List));
Set_Scope (Dnam, Scope (E));
Set_Assignment_OK (First (Declarations (Dbody)));
-- We only give the warning for non-imported entities of a type for
-- which a non-null base init proc is defined, or for objects of access
- -- types with implicit null initialization, or when Initialize_Scalars
+ -- 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).
+ -- 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. Also, do not warn if Suppress_Initialization is set.
if Present (Expr)
and then not Is_Imported (Ent)
+ and then not Initialization_Suppressed (Typ)
and then (Has_Non_Null_Base_Init_Proc (Typ)
- or else Is_Access_Type (Typ)
- or else (Init_Or_Norm_Scalars
- and then (Is_Scalar_Type (Typ)
- or else Is_String_Type (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))
begin
Comp := First_Component (Typ);
-
while Present (Comp) loop
if Nkind (Parent (Comp)) = N_Component_Declaration
and then Present (Expression (Parent (Comp)))
OSDN Git Service
