-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
-- Used to determine whether its body should be elaborated to allow
-- front-end inlining.
- function Is_Generic_Formal (E : Entity_Id) return Boolean;
- -- Utility to determine whether a given entity is declared by means of
- -- of a formal parameter declaration. Used to set properly the visibility
- -- of generic formals of a generic package declared with a box or with
- -- partial parametrization.
-
procedure Set_Instance_Env
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id);
-- initialized before call to Check_Generic_Child_Unit.
procedure Install_Formal_Packages (Par : Entity_Id);
- -- If any of the formals of the parent are formal packages with box,
- -- their formal parts are visible in the parent and thus in the child
- -- unit as well. Analogous to what is done in Check_Generic_Actuals
- -- for the unit itself. This procedure is also used in an instance, to
- -- make visible the proper entities of the actual for a formal package
- -- declared with a box.
+ -- Install the visible part of any formal of the parent that is a formal
+ -- package. Note that for the case of a formal package with a box, this
+ -- includes the formal part of the formal package (12.7(10/2)).
procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
-- When compiling an instance of a child unit the parent (which is
-- formals: the visible and private declarations themselves need not be
-- created.
- -- In Ada 2005, the formal package may be only partially parametrized. In
- -- that case the visibility step must make visible those actuals whose
+ -- In Ada 2005, the formal package may be only partially parameterized.
+ -- In that case the visibility step must make visible those actuals whose
-- corresponding formals were given with a box. A final complication
- -- involves inherited operations from formal derived types, which must be
- -- visible if the type is.
+ -- involves inherited operations from formal derived types, which must
+ -- be visible if the type is.
function Is_In_Main_Unit (N : Node_Id) return Boolean;
-- Test if given node is in the main unit
-- defining identifier for it.
Decl := New_Copy_Tree (F);
- Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id));
+ Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id));
if Nkind (F) in N_Formal_Subprogram_Declaration then
Set_Defining_Unit_Name (Specification (Decl), Id);
when N_Use_Package_Clause |
N_Use_Type_Clause =>
if Nkind (Original_Node (I_Node)) =
- N_Formal_Package_Declaration
+ N_Formal_Package_Declaration
then
Append (New_Copy_Tree (Formal), Assoc);
else
Lo :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
- Prefix => New_Reference_To (T, Loc));
+ Prefix => New_Reference_To (T, Loc));
Set_Etype (Lo, T);
Hi :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
- Prefix => New_Reference_To (T, Loc));
+ Prefix => New_Reference_To (T, Loc));
Set_Etype (Hi, T);
Set_Scalar_Range (T,
Make_Range (Loc,
- Low_Bound => Lo,
+ Low_Bound => Lo,
High_Bound => Hi));
Set_Ekind (Base, E_Enumeration_Type);
-- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
- if Ada_Version < Ada_05 and then Is_Limited_Type (T) then
+ if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then
Error_Msg_N
("generic formal of mode IN must not be of limited type", N);
Explain_Limited_Type (T, N);
if Present (E) then
Preanalyze_Spec_Expression (E, T);
- if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then
+ if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then
Error_Msg_N
("initialization not allowed for limited types", E);
Explain_Limited_Type (T, E);
("initialization not allowed for `IN OUT` formals", N);
end if;
end if;
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Formal_Object_Declaration;
----------------------------------------------
Check_Restriction (No_Fixed_Point, Def);
end Analyze_Formal_Ordinary_Fixed_Point_Type;
- ----------------------------
- -- Analyze_Formal_Package --
- ----------------------------
+ ----------------------------------------
+ -- Analyze_Formal_Package_Declaration --
+ ----------------------------------------
- procedure Analyze_Formal_Package (N : Node_Id) is
+ procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Pack_Id : constant Entity_Id := Defining_Identifier (N);
Formal : Entity_Id;
-- Check for a formal package that is a package renaming
if Present (Renamed_Object (Gen_Unit)) then
+
+ -- Indicate that unit is used, before replacing it with renamed
+ -- entity for use below.
+
+ if In_Extended_Main_Source_Unit (N) then
+ Set_Is_Instantiated (Gen_Unit);
+ Generate_Reference (Gen_Unit, N);
+ end if;
+
Gen_Unit := Renamed_Object (Gen_Unit);
end if;
if Ekind (Gen_Unit) /= E_Generic_Package then
Error_Msg_N ("expect generic package name", Gen_Id);
Restore_Env;
- return;
+ goto Leave;
elsif Gen_Unit = Current_Scope then
Error_Msg_N
("generic package cannot be used as a formal package of itself",
Gen_Id);
Restore_Env;
- return;
+ goto Leave;
elsif In_Open_Scopes (Gen_Unit) then
if Is_Compilation_Unit (Gen_Unit)
& "within itself",
Gen_Id);
Restore_Env;
- return;
+ goto Leave;
end if;
end if;
Remove_Parent;
end if;
- return;
+ goto Leave;
end;
Rewrite (N, New_N);
Set_Etype (Pack_Id, Standard_Void_Type);
Set_Scope (Pack_Id, Scope (Formal));
Set_Has_Completion (Pack_Id, True);
- end Analyze_Formal_Package;
+
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Pack_Id);
+ end if;
+ end Analyze_Formal_Package_Declaration;
---------------------------------
-- Analyze_Formal_Private_Type --
Set_Parent (Base, Parent (Def));
end Analyze_Formal_Signed_Integer_Type;
- -------------------------------
- -- Analyze_Formal_Subprogram --
- -------------------------------
+ -------------------------------------------
+ -- Analyze_Formal_Subprogram_Declaration --
+ -------------------------------------------
- procedure Analyze_Formal_Subprogram (N : Node_Id) is
+ procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is
Spec : constant Node_Id := Specification (N);
Def : constant Node_Id := Default_Name (N);
Nam : constant Entity_Id := Defining_Unit_Name (Spec);
if Nkind (Nam) = N_Defining_Program_Unit_Name then
Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
- return;
+ goto Leave;
end if;
Analyze_Subprogram_Declaration (N);
Analyze (Prefix (Def));
Valid_Default_Attribute (Nam, Def);
- return;
+ goto Leave;
end if;
-- Default name may be overloaded, in which case the interpretation
-- can be a protected operation.
if Etype (Def) = Any_Type then
- return;
+ goto Leave;
elsif Nkind (Def) = N_Selected_Component then
if not Is_Overloadable (Entity (Selector_Name (Def))) then
end if;
elsif Nkind (Prefix (Def)) = N_Selected_Component then
- if Ekind (Entity (Selector_Name (Prefix (Def))))
- /= E_Entry_Family
+ if Ekind (Entity (Selector_Name (Prefix (Def)))) /=
+ E_Entry_Family
then
Error_Msg_N ("expect valid subprogram name as default", Def);
end if;
else
Error_Msg_N ("expect valid subprogram name as default", Def);
- return;
+ goto Leave;
end if;
elsif Nkind (Def) = N_Character_Literal then
or else not Is_Overloadable (Entity (Def))
then
Error_Msg_N ("expect valid subprogram name as default", Def);
- return;
+ goto Leave;
elsif not Is_Overloaded (Def) then
Subp := Entity (Def);
end if;
end if;
end if;
- end Analyze_Formal_Subprogram;
+
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Nam);
+ end if;
+
+ end Analyze_Formal_Subprogram_Declaration;
-------------------------------------
-- Analyze_Formal_Type_Declaration --
end case;
Set_Is_Generic_Type (T);
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, T);
+ end if;
end Analyze_Formal_Type_Declaration;
------------------------------------
then
Error_Msg_N ("premature usage of incomplete type", Def);
- elsif Is_Internal (Designated_Type (T)) then
+ elsif not Is_Entity_Name (Subtype_Indication (Def)) then
Error_Msg_N
("only a subtype mark is allowed in a formal", Def);
end if;
Check_References (Id);
end if;
end if;
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Generic_Package_Declaration;
--------------------------------------------
Set_Parent_Spec (New_N, Save_Parent);
Rewrite (N, New_N);
+ -- The aspect specifications are not attached to the tree, and must
+ -- be copied and attached to the generic copy explicitly.
+
+ if Present (Aspect_Specifications (New_N)) then
+ declare
+ Aspects : constant List_Id := Aspect_Specifications (N);
+ begin
+ Set_Has_Aspects (N, False);
+ Move_Aspects (New_N, N);
+ Set_Has_Aspects (Original_Node (N), False);
+ Set_Aspect_Specifications (Original_Node (N), Aspects);
+ end;
+ end if;
+
Spec := Specification (N);
Id := Defining_Entity (Spec);
Generate_Definition (Id);
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
Result_Type := Access_Definition (Spec, Result_Definition (Spec));
Set_Etype (Id, Result_Type);
+
+ -- Check restriction imposed by AI05-073: a generic function
+ -- cannot return an abstract type or an access to such.
+
+ -- This is a binding interpretation should it apply to earlier
+ -- versions of Ada as well as Ada 2012???
+
+ if Is_Abstract_Type (Designated_Type (Result_Type))
+ and then Ada_Version >= Ada_2012
+ then
+ Error_Msg_N ("generic function cannot have an access result"
+ & " that designates an abstract type", Spec);
+ end if;
+
else
Find_Type (Result_Definition (Spec));
Typ := Entity (Result_Definition (Spec));
+ if Is_Abstract_Type (Typ)
+ and then Ada_Version >= Ada_2012
+ then
+ Error_Msg_N
+ ("generic function cannot have abstract result type", Spec);
+ end if;
+
-- If a null exclusion is imposed on the result type, then create
-- a null-excluding itype (an access subtype) and use it as the
-- function's Etype.
Save_Global_References (Original_Node (N));
+ -- To capture global references, analyze the expressions of aspects,
+ -- and propagate information to original tree. Note that in this case
+ -- analysis of attributes is not delayed until the freeze point.
+
+ -- It seems very hard to recreate the proper visibility of the generic
+ -- subprogram at a later point because the analysis of an aspect may
+ -- create pragmas after the generic copies have been made ???
+
+ if Has_Aspects (N) then
+ declare
+ Aspect : Node_Id;
+
+ begin
+ Aspect := First (Aspect_Specifications (N));
+ while Present (Aspect) loop
+ if Get_Aspect_Id (Chars (Identifier (Aspect)))
+ /= Aspect_Warnings
+ then
+ Analyze (Expression (Aspect));
+ end if;
+ Next (Aspect);
+ end loop;
+
+ Aspect := First (Aspect_Specifications (Original_Node (N)));
+ while Present (Aspect) loop
+ Save_Global_References (Expression (Aspect));
+ Next (Aspect);
+ end loop;
+ end;
+ end if;
+
End_Generic;
End_Scope;
Exit_Generic_Scope (Id);
Generate_Reference_To_Formals (Id);
+
+ List_Inherited_Pre_Post_Aspects (Id);
end Analyze_Generic_Subprogram_Declaration;
-----------------------------------
Needs_Body : Boolean;
Inline_Now : Boolean := False;
+ Save_Style_Check : constant Boolean := Style_Check;
+ -- Save style check mode for restore on exit
+
procedure Delay_Descriptors (E : Entity_Id);
-- Delay generation of subprogram descriptors for given entity
Instantiation_Node := N;
+ -- Turn off style checking in instances. If the check is enabled on the
+ -- generic unit, a warning in an instance would just be noise. If not
+ -- enabled on the generic, then a warning in an instance is just wrong.
+
+ Style_Check := False;
+
-- Case of instantiation of a generic package
if Nkind (N) = N_Package_Instantiation then
if Etype (Gen_Unit) = Any_Type then
Restore_Env;
- return;
+ goto Leave;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
end if;
Restore_Env;
- return;
+ goto Leave;
end if;
if In_Extended_Main_Source_Unit (N) then
if In_Open_Scopes (Gen_Unit) then
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
Restore_Env;
- return;
+ goto Leave;
elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
Error_Msg_Node_2 := Current_Scope;
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
Restore_Env;
- return;
+ goto Leave;
else
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
end if;
end;
- -- If we are generating the calling stubs from the instantiation of
- -- a generic RCI package, we will not use the body of the generic
- -- package.
+ -- If we are generating calling stubs, we never need a body for an
+ -- instantiation from source in the visible part, because in that
+ -- case we'll be generating stubs for any subprogram in the instance.
+ -- However normal processing occurs for instantiations in generated
+ -- code or in the private part, since in those cases we do not
+ -- generate stubs.
if Distribution_Stub_Mode = Generate_Caller_Stub_Body
- and then Is_Compilation_Unit (Defining_Entity (N))
+ and then Comes_From_Source (N)
then
Needs_Body := False;
end if;
Expander_Status => Expander_Active,
Current_Sem_Unit => Current_Sem_Unit,
Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top));
+ Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+ Version => Ada_Version));
end if;
end if;
Set_Defining_Identifier (N, Act_Decl_Id);
end if;
+ Style_Check := Save_Style_Check;
+
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Act_Decl_Id);
+ end if;
+
exception
when Instantiation_Error =>
if Parent_Installed then
if Env_Installed then
Restore_Env;
end if;
+
+ Style_Check := Save_Style_Check;
end Analyze_Package_Instantiation;
--------------------------
Cunit_Entity (Get_Source_Unit (Gen_Unit));
Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit);
Curr_Scope : Entity_Id := Empty;
- Curr_Unit : constant Entity_Id :=
- Cunit_Entity (Current_Sem_Unit);
+ Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
Removed : Boolean := False;
Num_Scopes : Int := 0;
Expander_Status => Expander_Active,
Current_Sem_Unit => Current_Sem_Unit,
Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)),
+ Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+ Version => Ada_Version)),
Inlined_Body => True);
Pop_Scope;
Expander_Status => Expander_Active,
Current_Sem_Unit => Current_Sem_Unit,
Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)),
+ Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+ Version => Ada_Version)),
Inlined_Body => True);
end if;
end Inline_Instance_Body;
Expander_Status => Expander_Active,
Current_Sem_Unit => Current_Sem_Unit,
Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top));
+ Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+ Version => Ada_Version));
return True;
else
return False;
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
+ Save_Style_Check : constant Boolean := Style_Check;
+ -- Save style check mode for restore on exit
+
procedure Analyze_Instance_And_Renamings;
-- The instance must be analyzed in a context that includes the mappings
-- of generic parameters into actuals. We create a package declaration
Check_Formal_Packages (Pack_Id);
Set_Is_Generic_Instance (Pack_Id, False);
+ -- Why do we clear Is_Generic_Instance??? We set it 20 lines
+ -- above???
+
-- Body of the enclosing package is supplied when instantiating the
-- subprogram body, after semantic analysis is completed.
-- If the instance is a child unit, mark the Id accordingly. Mark
-- the anonymous entity as well, which is the real subprogram and
-- which is used when the instance appears in a context clause.
+ -- Similarly, propagate the Is_Eliminated flag to handle properly
+ -- nested eliminated subprograms.
Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
New_Overloaded_Entity (Act_Decl_Id);
Check_Eliminated (Act_Decl_Id);
+ Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id));
-- In compilation unit case, kill elaboration checks on the
-- instantiation, since they are never needed -- the body is
-- Make node global for error reporting
Instantiation_Node := N;
+
+ -- Turn off style checking in instances. If the check is enabled on the
+ -- generic unit, a warning in an instance would just be noise. If not
+ -- enabled on the generic, then a warning in an instance is just wrong.
+
+ Style_Check := False;
+
Preanalyze_Actuals (N);
Init_Env;
-- Verify that it is a generic subprogram of the right kind, and that
-- it does not lead to a circular instantiation.
- if Ekind (Gen_Unit) /= E_Generic_Procedure
- and then Ekind (Gen_Unit) /= E_Generic_Function
- then
+ if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then
Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
elsif In_Open_Scopes (Gen_Unit) then
Error_Msg_NE
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
- return;
+ goto Leave;
end if;
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
Make_Subprogram_Declaration (Sloc (Act_Spec),
Specification => Act_Spec);
+ -- The aspects have been copied previously, but they have to be
+ -- linked explicitly to the new subprogram declaration. Explicit
+ -- pre/postconditions on the instance are analyzed below, in a
+ -- separate step.
+
+ Move_Aspects (Act_Tree, Act_Decl);
Set_Categorization_From_Pragmas (Act_Decl);
if Parent_Installed then
end if;
if Is_Dispatching_Operation (Act_Decl_Id)
- and then Ada_Version >= Ada_05
+ and then Ada_Version >= Ada_2005
then
declare
Formal : Entity_Id;
then
Error_Msg_NE ("access parameter& is controlling,",
N, Formal);
- Error_Msg_NE ("\corresponding parameter of & must be"
+ Error_Msg_NE
+ ("\corresponding parameter of & must be"
& " explicitly null-excluding", N, Gen_Id);
end if;
Generic_Renamings_HTable.Reset;
end if;
+ Style_Check := Save_Style_Check;
+
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Act_Decl_Id);
+ end if;
+
exception
when Instantiation_Error =>
if Parent_Installed then
if Env_Installed then
Restore_Env;
end if;
+
+ Style_Check := Save_Style_Check;
end Analyze_Subprogram_Instantiation;
-------------------------
-- The new compilation unit is linked to its body, but both share the
-- same file, so we do not set Body_Required on the new unit so as not
-- to create a spurious dependency on a non-existent body in the ali.
- -- This simplifies Codepeer unit traversal.
+ -- This simplifies CodePeer unit traversal.
-- We use the original instantiation compilation unit as the resulting
-- compilation unit of the instance, since this is the main unit.
procedure Check_Access_Definition (N : Node_Id) is
begin
pragma Assert
- (Ada_Version >= Ada_05
+ (Ada_Version >= Ada_2005
and then Present (Access_Definition (N)));
null;
end Check_Access_Definition;
-- that are attributes are rewritten as subprograms. If the
-- subprogram in the formal package is defaulted, no check is
-- needed. Note that this can only happen in Ada 2005 when the
- -- formal package can be partially parametrized.
+ -- formal package can be partially parameterized.
if Nkind (Unit_Declaration_Node (E1)) =
N_Subprogram_Renaming_Declaration
-- To detect this case we have to rescan the list of formals, which
-- is usually short enough to ignore the resulting inefficiency.
+ -----------------------------
+ -- Denotes_Previous_Actual --
+ -----------------------------
+
function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
Prev : Entity_Id;
+
begin
Prev := First_Entity (Instance);
while Present (Prev) loop
and then Entity (Subtype_Indication (Parent (Prev))) = Typ
then
return True;
+
elsif Prev = E then
return False;
+
else
Next_Entity (Prev);
end if;
end loop;
+
return False;
end Denotes_Previous_Actual;
else
Check_Private_View (Subtype_Indication (Parent (E)));
end if;
+
Set_Is_Generic_Actual_Type (E, True);
Set_Is_Hidden (E, False);
Set_Is_Potentially_Use_Visible (E,
Set_Is_Hidden (E, False);
end if;
+ if Ekind (E) = E_Constant then
+
+ -- If the type of the actual is a private type declared in the
+ -- enclosing scope of the generic unit, the body of the generic
+ -- sees the full view of the type (because it has to appear in
+ -- the corresponding package body). If the type is private now,
+ -- exchange views to restore the proper visiblity in the instance.
+
+ declare
+ Typ : constant Entity_Id := Base_Type (Etype (E));
+ -- The type of the actual
+
+ Gen_Id : Entity_Id;
+ -- The generic unit
+
+ Parent_Scope : Entity_Id;
+ -- The enclosing scope of the generic unit
+
+ begin
+ if Is_Wrapper_Package (Instance) then
+ Gen_Id :=
+ Generic_Parent
+ (Specification
+ (Unit_Declaration_Node
+ (Related_Instance (Instance))));
+ else
+ Gen_Id :=
+ Generic_Parent
+ (Specification (Unit_Declaration_Node (Instance)));
+ end if;
+
+ Parent_Scope := Scope (Gen_Id);
+
+ -- The exchange is only needed if the generic is defined
+ -- within a package which is not a common ancestor of the
+ -- scope of the instance, and is not already in scope.
+
+ if Is_Private_Type (Typ)
+ and then Scope (Typ) = Parent_Scope
+ and then Scope (Instance) /= Parent_Scope
+ and then Ekind (Parent_Scope) = E_Package
+ and then not Is_Child_Unit (Gen_Id)
+ then
+ Switch_View (Typ);
+
+ -- If the type of the entity is a subtype, it may also
+ -- have to be made visible, together with the base type
+ -- of its full view, after exchange.
+
+ if Is_Private_Type (Etype (E)) then
+ Switch_View (Etype (E));
+ Switch_View (Base_Type (Etype (E)));
+ end if;
+ end if;
+ end;
+ end if;
+
Next_Entity (E);
end loop;
end Check_Generic_Actuals;
elsif In_Open_Scopes (Inst_Par) then
- -- If the parent is already installed verify that the
- -- actuals for its formal packages declared with a box
- -- are already installed. This is necessary when the
- -- child instance is a child of the parent instance.
- -- In this case the parent is placed on the scope stack
+ -- If the parent is already installed, install the actuals
+ -- for its formal packages. This is necessary when the
+ -- child instance is a child of the parent instance:
+ -- in this case, the parent is placed on the scope stack
-- but the formal packages are not made visible.
Install_Formal_Packages (Inst_Par);
then
Install_Parent (Inst_Par);
Parent_Installed := True;
+
+ -- The generic unit may be the renaming of the implicit child
+ -- present in an instance. In that case the parent instance is
+ -- obtained from the name of the renamed entity.
+
+ elsif Ekind (Entity (Gen_Id)) = E_Generic_Package
+ and then Present (Renamed_Entity (Entity (Gen_Id)))
+ and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id)))
+ then
+ declare
+ Renamed_Package : constant Node_Id :=
+ Name (Parent (Entity (Gen_Id)));
+ begin
+ if Nkind (Renamed_Package) = N_Expanded_Name then
+ Inst_Par := Entity (Prefix (Renamed_Package));
+ Install_Parent (Inst_Par);
+ Parent_Installed := True;
+ end if;
+ end;
end if;
end if;
New_N := New_Copy (N);
+ -- Copy aspects if present
+
+ if Has_Aspects (N) then
+ Set_Has_Aspects (New_N, False);
+ Set_Aspect_Specifications
+ (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id));
+ end if;
+
if Instantiating then
Adjust_Instantiation_Sloc (New_N, S_Adjustment);
end if;
-- If we are not instantiating, then this is where we load and
-- analyze subunits, i.e. at the point where the stub occurs. A
- -- more permissible system might defer this analysis to the point
+ -- more permissive system might defer this analysis to the point
-- of instantiation, but this seems to complicated for now.
if not Instantiating then
New_Body : Node_Id;
begin
+ -- Make sure that, if it is a subunit of the main unit that is
+ -- preprocessed and if -gnateG is specified, the preprocessed
+ -- file will be written.
+
+ Lib.Analysing_Subunit_Of_Main :=
+ Lib.In_Extended_Main_Source_Unit (N);
Unum :=
Load_Unit
(Load_Name => Subunit_Name,
Required => False,
Subunit => True,
Error_Node => N);
+ Lib.Analysing_Subunit_Of_Main := False;
-- If the proper body is not found, a warning message will be
-- emitted when analyzing the stub, or later at the point
end if;
end if;
- -- Do not copy the associated node, which points to
- -- the generic copy of the aggregate.
+ -- Do not copy the associated node, which points to the generic copy
+ -- of the aggregate.
declare
use Atree.Unchecked_Access;
Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
end;
- -- Allocators do not have an identifier denoting the access type,
- -- so we must locate it through the expression to check whether
- -- the views are consistent.
+ -- Allocators do not have an identifier denoting the access type, so we
+ -- must locate it through the expression to check whether the views are
+ -- consistent.
elsif Nkind (N) = N_Allocator
and then Nkind (Expression (N)) = N_Qualified_Expression
-- Don't copy Ident or Comment pragmas, since the comment belongs to the
-- generic unit, not to the instantiating unit.
- elsif Nkind (N) = N_Pragma
- and then Instantiating
- then
+ elsif Nkind (N) = N_Pragma and then Instantiating then
declare
Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
begin
- if Prag_Id = Pragma_Ident
- or else Prag_Id = Pragma_Comment
- then
+ if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then
New_N := Make_Null_Statement (Sloc (N));
+
else
Copy_Descendants;
end if;
end;
- elsif Nkind_In (N, N_Integer_Literal,
- N_Real_Literal,
- N_String_Literal)
- then
+ elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
+
-- No descendant fields need traversing
null;
- -- For the remaining nodes, copy recursively their descendants
+ elsif Nkind (N) = N_String_Literal
+ and then Present (Etype (N))
+ and then Instantiating
+ then
+ -- If the string is declared in an outer scope, the string_literal
+ -- subtype created for it may have the wrong scope. We force the
+ -- reanalysis of the constant to generate a new itype in the proper
+ -- context.
+
+ Set_Etype (New_N, Empty);
+ Set_Analyzed (New_N, False);
+
+ -- For the remaining nodes, copy their descendants recursively
else
Copy_Descendants;
- if Instantiating
- and then Nkind (N) = N_Subprogram_Body
- then
+ if Instantiating and then Nkind (N) = N_Subprogram_Body then
Set_Generic_Parent (Specification (New_N), N);
+
+ -- Should preserve Corresponding_Spec??? (12.3(14))
end if;
end if;
if Renamed_Object (E1) = Pack then
return True;
- elsif E1 = P
- or else Renamed_Object (E1) = P
- then
+ elsif E1 = P or else Renamed_Object (E1) = P then
return False;
elsif Is_Actual_Of_Previous_Formal (E1) then
Instance_Envs.Table
(Instance_Envs.Last).Instantiated_Parent.Act_Id;
else
- Par := Current_Instantiated_Parent.Act_Id;
+ Par := Current_Instantiated_Parent.Act_Id;
end if;
if Ekind (Scop) = E_Generic_Package
end loop;
-- At this point P1 and P2 are at the same distance from the root.
- -- We examine their parents until we find a common declarative
- -- list, at which point we can establish their relative placement
- -- by comparing their ultimate slocs. If we reach the root,
- -- N1 and N2 do not descend from the same declarative list (e.g.
- -- one is nested in the declarative part and the other is in a block
- -- in the statement part) and the earlier one is already frozen.
+ -- We examine their parents until we find a common declarative list,
+ -- at which point we can establish their relative placement by
+ -- comparing their ultimate slocs. If we reach the root, N1 and N2
+ -- do not descend from the same declarative list (e.g. one is nested
+ -- in the declarative part and the other is in a block in the
+ -- statement part) and the earlier one is already frozen.
while not Is_List_Member (P1)
or else not Is_List_Member (P2)
In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
then
-- The enclosing package may contain several instances. Rather
- -- than computing the earliest point at which to insert its
- -- freeze node, we place it at the end of the declarative part
- -- of the parent of the generic.
+ -- than computing the earliest point at which to insert its freeze
+ -- node, we place it at the end of the declarative part of the
+ -- parent of the generic.
Insert_After_Last_Decl
(Freeze_Node (Par), Package_Freeze_Node (Enc_I));
-- Freeze package that encloses instance, and place node after
-- package that encloses generic. If enclosing package is already
- -- frozen we have to assume it is at the proper place. This may be
- -- a potential ABE that requires dynamic checking. Do not add a
- -- freeze node if the package that encloses the generic is inside
- -- the body that encloses the instance, because the freeze node
- -- would be in the wrong scope. Additional contortions needed if
- -- the bodies are within a subunit.
+ -- frozen we have to assume it is at the proper place. This may be a
+ -- potential ABE that requires dynamic checking. Do not add a freeze
+ -- node if the package that encloses the generic is inside the body
+ -- that encloses the instance, because the freeze node would be in
+ -- the wrong scope. Additional contortions needed if the bodies are
+ -- within a subunit.
declare
Enclosing_Body : Node_Id;
-- investigated, and would allow this function to be significantly
-- simplified. ???
- if Present (Package_Instantiation (A)) then
- if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then
- return Package_Instantiation (A);
+ Inst := Package_Instantiation (A);
- elsif Nkind (Original_Node (Package_Instantiation (A))) =
- N_Package_Instantiation
- then
- return Original_Node (Package_Instantiation (A));
+ if Present (Inst) then
+ if Nkind (Inst) = N_Package_Instantiation then
+ return Inst;
+
+ elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then
+ return Original_Node (Inst);
end if;
end if;
-- now we depend on the user not redefining Standard itself in one of
-- the parent units.
- if Is_Immediately_Visible (C)
- and then C /= Standard_Standard
- then
+ if Is_Immediately_Visible (C) and then C /= Standard_Standard then
Set_Is_Immediately_Visible (C, False);
Append_Elmt (C, Hidden_Entities);
end if;
-- might produce false positives in rare cases, but guarantees
-- that we produce all the instance bodies we will need.
- if (Is_Entity_Name (Nam)
- and then Chars (Nam) = Chars (E))
- or else (Nkind (Nam) = N_Selected_Component
- and then Chars (Selector_Name (Nam)) = Chars (E))
+ if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E))
+ or else (Nkind (Nam) = N_Selected_Component
+ and then Chars (Selector_Name (Nam)) = Chars (E))
then
return True;
end if;
begin
- -- If the body is a subunit, the freeze point is the corresponding
- -- stub in the current compilation, not the subunit itself.
+ -- If the body is a subunit, the freeze point is the corresponding stub
+ -- in the current compilation, not the subunit itself.
if Nkind (Parent (Gen_Body)) = N_Subunit then
Orig_Body := Corresponding_Stub (Parent (Gen_Body));
if Renamed_Object (E) = Par then
exit;
- -- The visibility of a formal of an enclosing generic is
- -- already correct.
+ -- The visibility of a formal of an enclosing generic is already
+ -- correct.
elsif Denotes_Formal_Package (E) then
null;
- elsif Present (Associated_Formal_Package (E))
- and then Box_Present (Parent (Associated_Formal_Package (E)))
- then
+ elsif Present (Associated_Formal_Package (E)) then
Check_Generic_Actuals (Renamed_Object (E), True);
Set_Is_Hidden (E, False);
-- Find formal package in generic unit that corresponds to
-- (instance of) formal package in instance.
- while Present (Gen_E)
- and then Chars (Gen_E) /= Chars (E)
- loop
+ while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop
Next_Entity (Gen_E);
end loop;
if not Box_Present (Formal) then
declare
I_Pack : constant Entity_Id :=
- Make_Defining_Identifier (Sloc (Actual),
- Chars => New_Internal_Name ('P'));
+ Make_Temporary (Sloc (Actual), 'P');
begin
Set_Is_Internal (I_Pack);
-- to prevent freezing anomalies.
declare
- Anon_Id : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('E'));
+ Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
+
begin
Set_Defining_Unit_Name (New_Spec, Anon_Id);
Insert_Before (Instantiation_Node, Decl_Node);
Actual : Node_Id;
Analyzed_Formal : Node_Id) return List_Id
is
+ Gen_Obj : constant Entity_Id := Defining_Identifier (Formal);
+ A_Gen_Obj : constant Entity_Id :=
+ Defining_Identifier (Analyzed_Formal);
Acc_Def : Node_Id := Empty;
Act_Assoc : constant Node_Id := Parent (Actual);
Actual_Decl : Node_Id := Empty;
- Formal_Id : constant Entity_Id := Defining_Identifier (Formal);
Decl_Node : Node_Id;
Def : Node_Id;
Ftyp : Entity_Id;
List : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (Actual);
- Orig_Ftyp : constant Entity_Id :=
- Etype (Defining_Identifier (Analyzed_Formal));
+ Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj);
Subt_Decl : Node_Id := Empty;
Subt_Mark : Node_Id := Empty;
-- Sloc for error message on missing actual
- Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal)));
+ Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj));
- if Get_Instance_Of (Formal_Id) /= Formal_Id then
+ if Get_Instance_Of (Gen_Obj) /= Gen_Obj then
Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
end if;
if No (Actual) then
Error_Msg_NE
("missing actual&",
- Instantiation_Node, Formal_Id);
+ Instantiation_Node, Gen_Obj);
Error_Msg_NE
("\in instantiation of & declared#",
- Instantiation_Node,
- Scope (Defining_Identifier (Analyzed_Formal)));
+ Instantiation_Node, Scope (A_Gen_Obj));
Abandon_Instantiation (Instantiation_Node);
end if;
if Present (Subt_Mark) then
Decl_Node :=
Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => New_Copy (Formal_Id),
+ Defining_Identifier => New_Copy (Gen_Obj),
Subtype_Mark => New_Copy_Tree (Subt_Mark),
Name => Actual);
else pragma Assert (Present (Acc_Def));
Decl_Node :=
Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => New_Copy (Formal_Id),
+ Defining_Identifier => New_Copy (Gen_Obj),
Access_Definition => New_Copy_Tree (Acc_Def),
Name => Actual);
end if;
end if;
-- The actual has to be resolved in order to check that it is a
- -- variable (due to cases such as F(1), where F returns
- -- access to an array, and for overloaded prefixes).
+ -- variable (due to cases such as F (1), where F returns access to an
+ -- array, and for overloaded prefixes).
- Ftyp :=
- Get_Instance_Of (Etype (Defining_Identifier (Analyzed_Formal)));
+ Ftyp := Get_Instance_Of (Etype (A_Gen_Obj));
+
+ -- If the type of the formal is not itself a formal, and the
+ -- current unit is a child unit, the formal type must be declared
+ -- in a parent, and must be retrieved by visibility.
+
+ if Ftyp = Orig_Ftyp
+ and then Is_Generic_Unit (Scope (Ftyp))
+ and then Is_Child_Unit (Scope (A_Gen_Obj))
+ then
+ declare
+ Temp : constant Node_Id :=
+ New_Copy_Tree (Subtype_Mark (Analyzed_Formal));
+ begin
+ Set_Entity (Temp, Empty);
+ Find_Type (Temp);
+ Ftyp := Entity (Temp);
+ end;
+ end if;
if Is_Private_Type (Ftyp)
and then not Is_Private_Type (Etype (Actual))
Subt_Decl :=
Make_Subtype_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
+ Defining_Identifier => Make_Temporary (Loc, 'P'),
Subtype_Indication => New_Occurrence_Of (Ftyp, Loc));
Prepend (Subt_Decl, List);
if not Denotes_Variable (Actual) then
Error_Msg_NE
- ("actual for& must be a variable", Actual, Formal_Id);
+ ("actual for& must be a variable", Actual, Gen_Obj);
elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
-- the type of the actual shall resolve to a specific anonymous
-- access type.
- if Ada_Version < Ada_05
+ if Ada_Version < Ada_2005
or else
Ekind (Base_Type (Ftyp)) /=
E_Anonymous_Access_Type
E_Anonymous_Access_Type
then
Error_Msg_NE ("type of actual does not match type of&",
- Actual, Formal_Id);
+ Actual, Gen_Obj);
end if;
end if;
"with volatile actual", Actual);
end if;
- -- formal in-parameter
+ -- Formal in-parameter
else
-- The instantiation of a generic formal in-parameter is constant
Decl_Node :=
Make_Object_Declaration (Loc,
- Defining_Identifier => New_Copy (Formal_Id),
+ Defining_Identifier => New_Copy (Gen_Obj),
Constant_Present => True,
Null_Exclusion_Present => Null_Exclusion_Present (Formal),
Object_Definition => New_Copy_Tree (Def),
-- A generic formal object of a tagged type is defined to be
-- aliased so the new constant must also be treated as aliased.
- if Is_Tagged_Type
- (Etype (Defining_Identifier (Analyzed_Formal)))
- then
+ if Is_Tagged_Type (Etype (A_Gen_Obj)) then
Set_Aliased_Present (Decl_Node);
end if;
end if;
declare
- Formal_Object : constant Entity_Id :=
- Defining_Identifier (Analyzed_Formal);
- Formal_Type : constant Entity_Id := Etype (Formal_Object);
-
- Typ : Entity_Id;
+ Formal_Type : constant Entity_Id := Etype (A_Gen_Obj);
+ Typ : Entity_Id;
begin
Typ := Get_Instance_Of (Formal_Type);
end if;
if Is_Limited_Type (Typ)
- and then not OK_For_Limited_Init (Actual)
+ and then not OK_For_Limited_Init (Typ, Actual)
then
Error_Msg_N
("initialization not allowed for limited types", Actual);
Decl_Node :=
Make_Object_Declaration (Sloc (Formal),
- Defining_Identifier => New_Copy (Formal_Id),
+ Defining_Identifier => New_Copy (Gen_Obj),
Constant_Present => True,
Null_Exclusion_Present => Null_Exclusion_Present (Formal),
Object_Definition => New_Copy (Def),
else
Error_Msg_NE
("missing actual&",
- Instantiation_Node, Formal_Id);
+ Instantiation_Node, Gen_Obj);
Error_Msg_NE ("\in instantiation of & declared#",
- Instantiation_Node,
- Scope (Defining_Identifier (Analyzed_Formal)));
+ Instantiation_Node, Scope (A_Gen_Obj));
+
+ if Is_Scalar_Type (Etype (A_Gen_Obj)) then
- if Is_Scalar_Type
- (Etype (Defining_Identifier (Analyzed_Formal)))
- then
-- Create dummy constant declaration so that instance can be
-- analyzed, to minimize cascaded visibility errors.
Decl_Node :=
Make_Object_Declaration (Loc,
- Defining_Identifier => New_Copy (Formal_Id),
+ Defining_Identifier => New_Copy (Gen_Obj),
Constant_Present => True,
Null_Exclusion_Present => Null_Exclusion_Present (Formal),
Object_Definition => New_Copy (Def),
Expression =>
- Make_Attribute_Reference (Sloc (Formal_Id),
+ Make_Attribute_Reference (Sloc (Gen_Obj),
Attribute_Name => Name_First,
Prefix => New_Copy (Def)));
-- Otherwise, the subtype of the actual matching the formal object
-- declaration shall exclude null.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Present (Actual_Decl)
and then
Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
Scope_Suppress := Body_Info.Scope_Suppress;
+ Opt.Ada_Version := Body_Info.Version;
if No (Gen_Body_Id) then
Load_Parent_Of_Generic
-- If we have no body, and the unit requires a body, then complain. This
-- complaint is suppressed if we have detected other errors (since a
-- common reason for missing the body is that it had errors).
+ -- In CodePeer mode, a warning has been emitted already, no need for
+ -- further messages.
elsif Unit_Requires_Body (Gen_Unit)
and then not Body_Optional
then
- if Serious_Errors_Detected = 0 then
+ if CodePeer_Mode then
+ null;
+
+ elsif Serious_Errors_Detected = 0 then
Error_Msg_NE
("cannot find body of generic package &", Inst_Node, Gen_Unit);
Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
Scope_Suppress := Body_Info.Scope_Suppress;
+ Opt.Ada_Version := Body_Info.Version;
if No (Gen_Body_Id) then
elsif Ekind (A_Gen_T) = E_General_Access_Type
and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
then
- Error_Msg_N ("actual must be general access type!", Actual);
- Error_Msg_NE ("add ALL to }!", Actual, Act_T);
+ Error_Msg_N -- CODEFIX
+ ("actual must be general access type!", Actual);
+ Error_Msg_NE -- CODEFIX
+ ("add ALL to }!", Actual, Act_T);
Abandon_Instantiation (Actual);
end if;
end if;
I2 := First_Index (Act_T);
for J in 1 .. Formal_Dimensions loop
- -- If the indices of the actual were given by a subtype_mark,
+ -- If the indexes of the actual were given by a subtype_mark,
-- the index was transformed into a range attribute. Retrieve
-- the original type mark for checking.
-- Ada 2005 (AI-251)
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Is_Interface (Ancestor)
then
if not Interface_Present_In_Ancestor (Act_T, Ancestor) then
-- that the formal type declaration has been rewritten as a private
-- extension.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration
and then Synchronized_Present (Parent (A_Gen_T))
then
end if;
end if;
- -- Perform atomic/volatile checks (RM C.6(12))
+ -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
+ -- removes the second instance of the phrase "or allow pass by copy".
if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
Error_Msg_N
("cannot have atomic actual type for non-atomic formal type",
Actual);
- elsif Is_Volatile (Act_T)
- and then not Is_Volatile (Ancestor)
- and then Is_By_Reference_Type (Ancestor)
- then
+ elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then
Error_Msg_N
("cannot have volatile actual type for non-volatile formal type",
Actual);
-- then so far the subprograms correspond, so
-- now check that any result types correspond.
- if No (Anc_Formal)
- and then No (Act_Formal)
- then
+ if No (Anc_Formal) and then No (Act_Formal) then
Subprograms_Correspond := True;
if Ekind (Act_Subp) = E_Function then
-- interface then the generic formal is not unless declared
-- explicitly so. If not declared limited, the actual cannot be
-- limited (see AI05-0087).
- -- Disable check for now, limited interfaces implemented by
- -- protected types are common, Need to update tests ???
+
+ -- Even though this AI is a binding interpretation, we enable the
+ -- check only in Ada 2012 mode, because this improper construct
+ -- shows up in user code and in existing B-tests.
if Is_Limited_Type (Act_T)
and then not Is_Limited_Type (A_Gen_T)
- and then False
+ and then Ada_Version >= Ada_2012
then
Error_Msg_NE
("actual for non-limited & cannot be a limited type", Actual,
-- parent, but the analyzed formal that includes the interface
-- operations of all its progenitors.
+ -- Same treatment for formal private types, so we can check whether the
+ -- type is tagged limited when validating derivations in the private
+ -- part. (See AI05-096).
+
if Nkind (Def) = N_Formal_Derived_Type_Definition then
if Present (Interface_List (Def)) then
Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
end if;
elsif Nkind (Def) = N_Formal_Private_Type_Definition then
- Set_Generic_Parent_Type (Decl_Node, Ancestor);
+ Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
end if;
-- If the actual is a synchronized type that implements an interface,
Corr_Decl : Node_Id;
begin
- New_Corr := Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ New_Corr := Make_Temporary (Loc, 'S');
Corr_Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => New_Corr,
return Decl_Nodes;
end Instantiate_Type;
- -----------------------
- -- Is_Generic_Formal --
- -----------------------
-
- function Is_Generic_Formal (E : Entity_Id) return Boolean is
- Kind : Node_Kind;
- begin
- if No (E) then
- return False;
- else
- Kind := Nkind (Parent (E));
- return
- Nkind_In (Kind, N_Formal_Object_Declaration,
- N_Formal_Package_Declaration,
- N_Formal_Type_Declaration)
- or else
- (Is_Formal_Subprogram (E)
- and then
- Nkind (Parent (Parent (E))) in
- N_Formal_Subprogram_Declaration);
- end if;
- end Is_Generic_Formal;
-
---------------------
-- Is_In_Main_Unit --
---------------------
-- instantiations are available, we must analyze them, to ensure that
-- the public symbols generated are the same when the unit is compiled
-- to generate code, and when it is compiled in the context of a unit
- -- that needs a particular nested instance. This process is applied
- -- to both package and subprogram instances.
+ -- that needs a particular nested instance. This process is applied to
+ -- both package and subprogram instances.
--------------------------------
-- Collect_Previous_Instances --
-- declared without a box (see Instantiate_Formal_Package). Such
-- an instantiation does not generate any code (the actual code
-- comes from actual) and thus does not need to be analyzed here.
+ -- If the instantiation appears with a generic package body it is
+ -- not analyzed here either.
elsif Nkind (Decl) = N_Package_Instantiation
and then not Is_Internal (Defining_Entity (Decl))
then
Append_Elmt (Decl, Previous_Instances);
- -- For a subprogram instantiation, omit instantiations of
- -- intrinsic operations (Unchecked_Conversions, etc.) that
- -- have no bodies.
+ -- For a subprogram instantiation, omit instantiations intrinsic
+ -- operations (Unchecked_Conversions, etc.) that have no bodies.
elsif Nkind_In (Decl, N_Function_Instantiation,
N_Procedure_Instantiation)
Collect_Previous_Instances
(Private_Declarations (Specification (Decl)));
- elsif Nkind (Decl) = N_Package_Body then
+ -- Previous non-generic bodies may contain instances as well
+
+ elsif Nkind (Decl) = N_Package_Body
+ and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
+ then
+ Collect_Previous_Instances (Declarations (Decl));
+
+ elsif Nkind (Decl) = N_Subprogram_Body
+ and then not Acts_As_Spec (Decl)
+ and then not Is_Generic_Subprogram (Corresponding_Spec (Decl))
+ then
Collect_Previous_Instances (Declarations (Decl));
end if;
and then Nkind (True_Parent) /= N_Compilation_Unit
loop
if Nkind (True_Parent) = N_Package_Declaration
- and then
- Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
+ and then
+ Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
then
-- Parent is a compilation unit that is an instantiation.
-- Instantiation node has been replaced with package decl.
Set_Unit (Parent (True_Parent), Inst_Node);
end if;
- -- Now complete instantiation of enclosing body, if it appears
- -- in some other unit. If it appears in the current unit, the
- -- body will have been instantiated already.
+ -- Now complete instantiation of enclosing body, if it appears in
+ -- some other unit. If it appears in the current unit, the body
+ -- will have been instantiated already.
if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
-- enclosing body. Because the generic body we need may use
-- global entities declared in the enclosing package (including
-- aggregates) it is in general necessary to compile this body
- -- with expansion enabled. The exception is if we are within a
- -- generic package, in which case the usual generic rule
- -- applies.
+ -- with expansion enabled, except if we are within a generic
+ -- package, in which case the usual generic rule applies.
declare
Exp_Status : Boolean := True;
Scop := Scope (Scop);
end loop;
- -- Collect previous instantiations in the unit that
- -- contains the desired generic.
+ -- Collect previous instantiations in the unit that contains
+ -- the desired generic.
if Nkind (Parent (True_Parent)) /= N_Compilation_Unit
and then not Body_Optional
(Private_Declarations (Specification (Par)));
else
- -- Enclosing unit is a subprogram body, In this
+ -- Enclosing unit is a subprogram body. In this
-- case all instance bodies are processed in order
-- and there is no need to collect them separately.
Get_Code_Unit (Sloc (Node (Decl))),
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top =>
- Local_Suppress_Stack_Top);
+ Local_Suppress_Stack_Top,
+ Version => Ada_Version);
-- Package instance
Get_Code_Unit (Sloc (Inst_Node)),
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top =>
- Local_Suppress_Stack_Top)),
+ Local_Suppress_Stack_Top,
+ Version => Ada_Version)),
Body_Optional => Body_Optional);
end;
end if;
Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
begin
- Error_Msg_Unit_1 := Bname;
- Error_Msg_N ("this instantiation requires$!", N);
- Error_Msg_File_1 := Get_File_Name (Bname, Subunit => False);
- Error_Msg_N ("\but file{ was not found!", N);
- raise Unrecoverable_Error;
+ -- In CodePeer mode, the missing body may make the analysis
+ -- incomplete, but we do not treat it as fatal.
+
+ if CodePeer_Mode then
+ return;
+
+ else
+ Error_Msg_Unit_1 := Bname;
+ Error_Msg_N ("this instantiation requires$!", N);
+ Error_Msg_File_1 :=
+ Get_File_Name (Bname, Subunit => False);
+ Error_Msg_N ("\but file{ was not found!", N);
+ raise Unrecoverable_Error;
+ end if;
end;
end if;
end if;
E1 := First_Entity (Form);
E2 := First_Entity (Act);
- while Present (E1)
- and then E1 /= First_Private_Entity (Form)
- loop
+ while Present (E1) and then E1 /= First_Private_Entity (Form) loop
-- Could this test be a single condition???
-- Seems like it could, and isn't FPE (Form) a constant anyway???
and then not Is_Class_Wide_Type (E1)
and then not Is_Internal_Name (Chars (E1))
then
- while Present (E2)
- and then Chars (E2) /= Chars (E1)
- loop
+ while Present (E2) and then Chars (E2) /= Chars (E1) loop
Next_Entity (E2);
end loop;
else
Set_Instance_Of (E1, E2);
- if Is_Type (E1)
- and then Is_Tagged_Type (E2)
- then
- Set_Instance_Of
- (Class_Wide_Type (E1), Class_Wide_Type (E2));
+ if Is_Type (E1) and then Is_Tagged_Type (E2) then
+ Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2));
end if;
if Is_Constrained (E1) then
- Set_Instance_Of
- (Base_Type (E1), Base_Type (E2));
+ Set_Instance_Of (Base_Type (E1), Base_Type (E2));
end if;
- if Ekind (E1) = E_Package
- and then No (Renamed_Object (E1))
- then
+ if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then
Map_Formal_Package_Entities (E1, E2);
end if;
end if;
-- recurse. Nested generic packages will have been processed from the
-- inside out.
- if Nkind (Decl) = N_Package_Declaration then
- Spec := Specification (Decl);
+ case Nkind (Decl) is
+ when N_Package_Declaration =>
+ Spec := Specification (Decl);
- elsif Nkind (Decl) = N_Task_Type_Declaration then
- Spec := Task_Definition (Decl);
+ when N_Task_Type_Declaration =>
+ Spec := Task_Definition (Decl);
- elsif Nkind (Decl) = N_Protected_Type_Declaration then
- Spec := Protected_Definition (Decl);
+ when N_Protected_Type_Declaration =>
+ Spec := Protected_Definition (Decl);
- else
- Spec := Empty;
- end if;
+ when others =>
+ Spec := Empty;
+ end case;
if Present (Spec) then
- Move_Freeze_Nodes (Out_Of, Next_Node,
- Visible_Declarations (Spec));
- Move_Freeze_Nodes (Out_Of, Next_Node,
- Private_Declarations (Spec));
+ Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec));
+ Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec));
end if;
Next (Decl);
procedure Remove_Parent (In_Body : Boolean := False) is
S : Entity_Id := Current_Scope;
- -- S is the scope containing the instantiation just completed. The
- -- scope stack contains the parent instances of the instantiation,
- -- followed by the original S.
+ -- S is the scope containing the instantiation just completed. The scope
+ -- stack contains the parent instances of the instantiation, followed by
+ -- the original S.
+ Cur_P : Entity_Id;
E : Entity_Id;
P : Entity_Id;
Hidden : Elmt_Id;
Next_Entity (E);
end loop;
- if Is_Generic_Instance (Current_Scope)
- and then P /= Current_Scope
- then
+ -- If instantiation is declared in a block, it is the enclosing
+ -- scope that might be a parent instance. Note that only one
+ -- block can be involved, because the parent instances have
+ -- been installed within it.
+
+ if Ekind (P) = E_Block then
+ Cur_P := Scope (P);
+ else
+ Cur_P := P;
+ end if;
+
+ if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then
-- We are within an instance of some sibling. Retain
- -- visibility of parent, for proper subsequent cleanup,
- -- and reinstall private declarations as well.
+ -- visibility of parent, for proper subsequent cleanup, and
+ -- reinstall private declarations as well.
Set_In_Private_Part (P);
Install_Private_Declarations (P);
end if;
-- If the ultimate parent is a top-level unit recorded in
- -- Instance_Parent_Unit, then reset its visibility to what
- -- it was before instantiation. (It's not clear what the
- -- purpose is of testing whether Scope (P) is In_Open_Scopes,
- -- but that test was present before the ultimate parent test
- -- was added.???)
+ -- Instance_Parent_Unit, then reset its visibility to what it was
+ -- before instantiation. (It's not clear what the purpose is of
+ -- testing whether Scope (P) is In_Open_Scopes, but that test was
+ -- present before the ultimate parent test was added.???)
elsif not In_Open_Scopes (Scope (P))
or else (P = Instance_Parent_Unit
-- subunit of a generic contains an instance of a child unit of
-- its generic parent unit.
- elsif S = Current_Scope
- and then Is_Generic_Instance (S)
- then
+ elsif S = Current_Scope and then Is_Generic_Instance (S) then
declare
Par : constant Entity_Id :=
Generic_Parent
end loop;
else
- -- Each body is analyzed separately, and there is no context
- -- that needs preserving from one body instance to the next,
- -- so remove all parent scopes that have been installed.
+ -- Each body is analyzed separately, and there is no context that
+ -- needs preserving from one body instance to the next, so remove all
+ -- parent scopes that have been installed.
while Present (S) loop
End_Package_Scope (S);
begin
if No (Current_Instantiated_Parent.Act_Id) then
-
-- Restore environment after subprogram inlining
Restore_Private_Views (Empty);
Dep_Typ : Node_Id;
procedure Restore_Nested_Formal (Formal : Entity_Id);
- -- Hide the generic formals of formal packages declared with box
- -- which were reachable in the current instantiation.
+ -- Hide the generic formals of formal packages declared with box which
+ -- were reachable in the current instantiation.
---------------------------
-- Restore_Nested_Formal --
while Present (M) loop
Typ := Node (M);
- -- Subtypes of types whose views have been exchanged, and that
- -- are defined within the instance, were not on the list of
- -- Private_Dependents on entry to the instance, so they have to
- -- be exchanged explicitly now, in order to remain consistent with
- -- the view of the parent type.
+ -- Subtypes of types whose views have been exchanged, and that are
+ -- defined within the instance, were not on the Private_Dependents
+ -- list on entry to the instance, so they have to be exchanged
+ -- explicitly now, in order to remain consistent with the view of the
+ -- parent type.
- if Ekind (Typ) = E_Private_Type
- or else Ekind (Typ) = E_Limited_Private_Type
- or else Ekind (Typ) = E_Record_Type_With_Private
+ if Ekind_In (Typ, E_Private_Type,
+ E_Limited_Private_Type,
+ E_Record_Type_With_Private)
then
Dep_Elmt := First_Elmt (Private_Dependents (Typ));
while Present (Dep_Elmt) loop
return;
end if;
- -- Make the generic formal parameters private, and make the formal
- -- types into subtypes of the actuals again.
+ -- Make the generic formal parameters private, and make the formal types
+ -- into subtypes of the actuals again.
E := First_Entity (Pack_Id);
while Present (E) loop
-- An unusual case of aliasing: the actual may also be directly
-- visible in the generic, and be private there, while it is fully
-- visible in the context of the instance. The internal subtype
- -- is private in the instance, but has full visibility like its
+ -- is private in the instance but has full visibility like its
-- parent in the enclosing scope. This enforces the invariant that
-- the privacy status of all private dependents of a type coincide
-- with that of the parent type. This can only happen when a
- -- generic child unit is instantiated within sibling.
+ -- generic child unit is instantiated within a sibling.
if Is_Private_Type (E)
and then not Is_Private_Type (Etype (E))
-- a formal package, make its own formals private as well. The
-- actual in this case is itself the renaming of an instantiation.
-- If the entity is not a package renaming, it is the entity
- -- created to validate formal package actuals: ignore.
+ -- created to validate formal package actuals: ignore it.
-- If the actual is itself a formal package for the enclosing
-- generic, or the actual for such a formal package, it remains
-- visible on exit from the instance, and therefore nothing needs
-- to be done either, except to keep it accessible.
- if Is_Package
- and then Renamed_Object (E) = Pack_Id
- then
+ if Is_Package and then Renamed_Object (E) = Pack_Id then
exit;
elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
N2 := Get_Associated_Node (N);
E := Entity (N2);
+ -- If the entity is an itype created as a subtype of an access type
+ -- with a null exclusion restore source entity for proper visibility.
+ -- The itype will be created anew in the instance.
+
if Present (E) then
+ if Is_Itype (E)
+ and then Ekind (E) = E_Access_Subtype
+ and then Is_Entity_Name (N)
+ and then Chars (Etype (E)) = Chars (N)
+ then
+ E := Etype (E);
+ Set_Entity (N2, E);
+ Set_Etype (N2, E);
+ end if;
+
if Is_Global (E) then
Set_Global_Type (N, N2);
elsif Nkind (N) = N_Op_Concat
and then Is_Generic_Type (Etype (N2))
- and then
- (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
- or else Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
+ and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
+ or else
+ Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
and then Is_Intrinsic_Subprogram (E)
then
null;
and then Is_Generic_Unit (Scope (Gen_Id))
and then In_Open_Scopes (Scope (Gen_Id))
then
- -- This is an instantiation of a child unit within a sibling,
- -- so that the generic parent is in scope. An eventual instance
- -- must occur within the scope of an instance of the parent.
- -- Make name in instance into an expanded name, to preserve the
- -- identifier of the parent, so it can be resolved subsequently.
+ -- This is an instantiation of a child unit within a sibling, so
+ -- that the generic parent is in scope. An eventual instance must
+ -- occur within the scope of an instance of the parent. Make name
+ -- in instance into an expanded name, to preserve the identifier
+ -- of the parent, so it can be resolved subsequently.
Rewrite (Name (N2),
Make_Expanded_Name (Loc,
elsif Nkind (N2) = N_Explicit_Dereference then
-- An identifier is rewritten as a dereference if it is the
- -- prefix in an implicit dereference.
-
- -- Check whether corresponding entity in prefix is global
+ -- prefix in an implicit dereference (call or attribute).
+ -- The analysis of an instantiation will expand the node
+ -- again, so we preserve the original tree but link it to
+ -- the resolved entity in case it is global.
if Is_Entity_Name (Prefix (N2))
and then Present (Entity (Prefix (N2)))
and then Is_Global (Entity (Prefix (N2)))
then
- Rewrite (N,
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Occurrence_Of (Entity (Prefix (N2)), Loc)));
+ Set_Associated_Node (N, Prefix (N2));
+
elsif Nkind (Prefix (N2)) = N_Function_Call
and then Is_Global (Entity (Name (Prefix (N2))))
then
Act_Unit : Entity_Id)
is
begin
- -- Regardless of the current mode, predefined units are analyzed in
- -- the most current Ada mode, and earlier version Ada checks do not
- -- apply to predefined units. Nothing needs to be done for non-internal
- -- units. These are always analyzed in the current mode.
+ -- Regardless of the current mode, predefined units are analyzed in the
+ -- most current Ada mode, and earlier version Ada checks do not apply
+ -- to predefined units. Nothing needs to be done for non-internal units.
+ -- These are always analyzed in the current mode.
if Is_Internal_File_Name
- (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
- Renamings_Included => True)
+ (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
+ Renamings_Included => True)
then
Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit);
end if;
- Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
+ Current_Instantiated_Parent :=
+ (Gen_Id => Gen_Unit,
+ Act_Id => Act_Unit,
+ Next_In_HTable => Assoc_Null);
end Set_Instance_Env;
-----------------
projects / thirdparty / gcc.git / blobdiff