-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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 Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Rident; use Rident;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
with Sem_Elab; use Sem_Elab;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
-- in-out, because in the case of an anonymous type the entity is
-- actually created in the procedure.
- -- The following procedures treat other kinds of formal parameters.
+ -- The following procedures treat other kinds of formal parameters
procedure Analyze_Formal_Derived_Type
(N : Node_Id;
T : Entity_Id;
Def : Node_Id);
- -- All the following need comments???
+ -- The following subprograms create abbreviated declarations for formal
+ -- scalar types. We introduce an anonymous base of the proper class for
+ -- each of them, and define the formals as constrained first subtypes of
+ -- their bases. The bounds are expressions that are non-static in the
+ -- generic.
procedure Analyze_Formal_Decimal_Fixed_Point_Type
(T : Entity_Id; Def : Node_Id);
function Analyze_Associations
(I_Node : Node_Id;
Formals : List_Id;
- F_Copy : List_Id)
- return List_Id;
+ F_Copy : List_Id) return List_Id;
-- At instantiation time, build the list of associations between formals
-- and actuals. Each association becomes a renaming declaration for the
-- formal entity. F_Copy is the analyzed list of formals in the generic
-- On return, the node N has been rewritten with the actual body.
procedure Check_Formal_Packages (P_Id : Entity_Id);
- -- Apply the following to all formal packages in generic associations.
+ -- Apply the following to all formal packages in generic associations
procedure Check_Formal_Package_Instance
(Formal_Pack : Entity_Id;
function Contains_Instance_Of
(Inner : Entity_Id;
Outer : Entity_Id;
- N : Node_Id)
- return Boolean;
+ N : Node_Id) return Boolean;
-- Inner is instantiated within the generic Outer. Check whether Inner
-- directly or indirectly contains an instance of Outer or of one of its
-- parents, in the case of a subunit. Each generic unit holds a list of
-- determines whether the set of such lists contains a cycle, i.e. an
-- illegal circular instantiation.
- function Denotes_Formal_Package (Pack : Entity_Id) return Boolean;
+ function Denotes_Formal_Package
+ (Pack : Entity_Id;
+ On_Exit : Boolean := False) return Boolean;
-- Returns True if E is a formal package of an enclosing generic, or
- -- the actual for such a formal in an enclosing instantiation. Used in
- -- Restore_Private_Views, to keep the formals of such a package visible
- -- on exit from an inner instantiation.
+ -- the actual for such a formal in an enclosing instantiation. If such
+ -- a package is used as a formal in an nested generic, or as an actual
+ -- in a nested instantiation, the visibility of ITS formals should not
+ -- be modified. When called from within Restore_Private_Views, the flag
+ -- On_Exit is true, to indicate that the search for a possible enclosing
+ -- instance should ignore the current one.
function Find_Actual_Type
(Typ : Entity_Id;
- Gen_Scope : Entity_Id)
- return Entity_Id;
+ Gen_Scope : Entity_Id) return Entity_Id;
-- When validating the actual types of a child instance, check whether
-- the formal is a formal type of the parent unit, and retrieve the current
-- actual for it. Typ is the entity in the analyzed formal type declaration
function In_Same_Declarative_Part
(F_Node : Node_Id;
- Inst : Node_Id)
- return Boolean;
+ Inst : Node_Id) return Boolean;
-- True if the instantiation Inst and the given freeze_node F_Node appear
-- within the same declarative part, ignoring subunits, but with no inter-
-- vening suprograms or concurrent units. If true, the freeze node
-- of the instance can be placed after the freeze node of the parent,
-- which it itself an instance.
+ function In_Main_Context (E : Entity_Id) return Boolean;
+ -- Check whether an instantiation is in the context of the main unit.
+ -- Used to determine whether its body should be elaborated to allow
+ -- front-end inlining.
+
procedure Set_Instance_Env
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id);
-- When compiling an instance of a child unit the parent (which is
-- itself an instance) is an enclosing scope that must be made
-- immediately visible. This procedure is also used to install the non-
- -- generic parent of a generic child unit when compiling its body, so that
- -- full views of types in the parent are made visible.
+ -- generic parent of a generic child unit when compiling its body, so
+ -- that full views of types in the parent are made visible.
procedure Remove_Parent (In_Body : Boolean := False);
- -- Reverse effect after instantiation of child is complete.
+ -- Reverse effect after instantiation of child is complete
procedure Inline_Instance_Body
(N : Node_Id;
-- that successive instantiations succeed.
-- The functions Instantiate_XXX perform various legality checks and build
- -- the declarations for instantiated generic parameters.
- -- Need to describe what the parameters are ???
+ -- the declarations for instantiated generic parameters. In all of these
+ -- Formal is the entity in the generic unit, Actual is the entity of
+ -- expression in the generic associations, and Analyzed_Formal is the
+ -- formal in the generic copy, which contains the semantic information to
+ -- be used to validate the actual.
function Instantiate_Object
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
- return List_Id;
+ Analyzed_Formal : Node_Id) return List_Id;
function Instantiate_Type
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id;
- Actual_Decls : List_Id)
- return Node_Id;
+ Actual_Decls : List_Id) return Node_Id;
function Instantiate_Formal_Subprogram
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
- return Node_Id;
+ Analyzed_Formal : Node_Id) return Node_Id;
function Instantiate_Formal_Package
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
- return List_Id;
+ Analyzed_Formal : Node_Id) return List_Id;
-- If the formal package is declared with a box, special visibility rules
-- apply to its formals: they are in the visible part of the package. This
-- is true in the declarative region of the formal package, that is to say
procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr;
function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id;
- function Hash (F : Entity_Id) return HTable_Range;
+ function Hash (F : Entity_Id) return HTable_Range;
package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
Header_Num => HTable_Range,
-- that the visibility data structures be properly initialized. Once the
-- generic is unit is validated, Set_Instance_Env completes Save_Env.
+ Parent_Unit_Visible : Boolean := False;
+ -- Parent_Unit_Visible is used when the generic is a child unit, and
+ -- indicates whether the ultimate parent of the generic is visible in the
+ -- instantiation environment. It is used to reset the visiblity of the
+ -- parent at the end of the instantiation (see Remove_Parent).
+
type Instance_Env is record
- Ada_83 : Boolean;
+ Ada_Version : Ada_Version_Type;
Instantiated_Parent : Assoc;
Exchanged_Views : Elist_Id;
Hidden_Entities : Elist_Id;
Current_Sem_Unit : Unit_Number_Type;
+ Parent_Unit_Visible : Boolean := False;
end record;
package Instance_Envs is new Table.Table (
function Analyze_Associations
(I_Node : Node_Id;
Formals : List_Id;
- F_Copy : List_Id)
- return List_Id
+ F_Copy : List_Id) return List_Id
is
- Actual_Types : constant Elist_Id := New_Elmt_List;
- Assoc : constant List_Id := New_List;
- Defaults : constant Elist_Id := New_Elmt_List;
- Gen_Unit : constant Entity_Id := Defining_Entity
- (Parent (F_Copy));
+ Actual_Types : constant Elist_Id := New_Elmt_List;
+ Assoc : constant List_Id := New_List;
+ Defaults : constant Elist_Id := New_Elmt_List;
+ Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy));
Actuals : List_Id;
Actual : Node_Id;
Formal : Node_Id;
Num_Actuals : Int := 0;
function Matching_Actual
- (F : Entity_Id;
- A_F : Entity_Id)
- return Node_Id;
+ (F : Entity_Id;
+ A_F : Entity_Id) return Node_Id;
-- Find actual that corresponds to a given a formal parameter. If the
-- actuals are positional, return the next one, if any. If the actuals
-- are named, scan the parameter associations to find the right one.
---------------------
function Matching_Actual
- (F : Entity_Id;
- A_F : Entity_Id)
- return Node_Id
+ (F : Entity_Id;
+ A_F : Entity_Id) return Node_Id
is
Found : Node_Id;
Prev : Node_Id;
case Nkind (Formal) is
when N_Formal_Subprogram_Declaration =>
- exit when Kind = N_Formal_Subprogram_Declaration
+ exit when Kind in N_Formal_Subprogram_Declaration
and then
Chars
(Defining_Unit_Name (Specification (Formal))) =
-- unrecognized pragmas.
exit when
- Kind /= N_Formal_Subprogram_Declaration
+ Kind not in N_Formal_Subprogram_Declaration
and then Kind /= N_Subprogram_Declaration
and then Kind /= N_Freeze_Entity
and then Kind /= N_Null_Statement
then
Temp_Formal := First (Formals);
while Present (Temp_Formal) loop
- if Nkind (Temp_Formal) =
+ if Nkind (Temp_Formal) in
N_Formal_Subprogram_Declaration
and then Temp_Formal /= Formal
and then
then
Error_Msg_N ("premature usage of incomplete type", Def);
+ -- Check that range constraint is not allowed on the component type
+ -- of a generic formal array type (AARM 12.5.3(3))
+
elsif Is_Internal (Component_Type (T))
+ and then Present (Subtype_Indication (Component_Definition (Def)))
and then Nkind (Original_Node
(Subtype_Indication (Component_Definition (Def))))
- /= N_Attribute_Reference
+ = N_Subtype_Indication
then
Error_Msg_N
- ("only a subtype mark is allowed in a formal",
- Subtype_Indication (Component_Definition (Def)));
+ ("in a formal, a subtype indication can only be "
+ & "a subtype mark ('R'M 12.5.3(3))",
+ Subtype_Indication (Component_Definition (Def)));
end if;
end Analyze_Formal_Array_Type;
Set_Delta_Value (T, Delta_Val);
Set_Small_Value (T, Delta_Val);
Set_Scalar_Range (T, Scalar_Range (Base));
+ Set_Is_Constrained (T);
Check_Restriction (No_Fixed_Point, Def);
end Analyze_Formal_Decimal_Fixed_Point_Type;
Lo : Node_Id;
Hi : Node_Id;
+ Base : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
begin
- Enter_Name (T);
- Set_Ekind (T, E_Enumeration_Type);
- Set_Etype (T, T);
- Init_Size (T, 8);
- Init_Alignment (T);
+ Enter_Name (T);
+ Set_Ekind (T, E_Enumeration_Subtype);
+ Set_Etype (T, Base);
+ Init_Size (T, 8);
+ Init_Alignment (T);
+ Set_Is_Generic_Type (T);
+ Set_Is_Constrained (T);
-- For semantic analysis, the bounds of the type must be set to some
-- non-static value. The simplest is to create attribute nodes for
Low_Bound => Lo,
High_Bound => Hi));
+ Set_Ekind (Base, E_Enumeration_Type);
+ Set_Etype (Base, Base);
+ Init_Size (Base, 8);
+ Init_Alignment (Base);
+ Set_Is_Generic_Type (Base);
+ Set_Scalar_Range (Base, Scalar_Range (T));
+ Set_Parent (Base, Parent (Def));
+
end Analyze_Formal_Discrete_Type;
----------------------------------
-- the generic itself.
Enter_Name (T);
- Set_Ekind (T, E_Floating_Point_Subtype);
- Set_Etype (T, Base);
- Set_Size_Info (T, (Standard_Float));
- Set_RM_Size (T, RM_Size (Standard_Float));
- Set_Digits_Value (T, Digits_Value (Standard_Float));
- Set_Scalar_Range (T, Scalar_Range (Standard_Float));
+ Set_Ekind (T, E_Floating_Point_Subtype);
+ Set_Etype (T, Base);
+ Set_Size_Info (T, (Standard_Float));
+ Set_RM_Size (T, RM_Size (Standard_Float));
+ Set_Digits_Value (T, Digits_Value (Standard_Float));
+ Set_Scalar_Range (T, Scalar_Range (Standard_Float));
+ Set_Is_Constrained (T);
Set_Is_Generic_Type (Base);
Set_Etype (Base, Base);
if K = E_Generic_In_Parameter then
- -- Ada0Y (AI-287): Limited aggregates allowed in generic formals
+ -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
- if not Extensions_Allowed and then Is_Limited_Type (T) then
+ if Ada_Version < Ada_05 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);
Set_Ekind (Id, K);
Set_Etype (Id, T);
- -- Case of generic IN OUT parameter.
+ -- Case of generic IN OUT parameter
else
-- If the formal has an unconstrained type, construct its
Make_Range (Loc,
Low_Bound => Make_Real_Literal (Loc, Ureal_1),
High_Bound => Make_Real_Literal (Loc, Ureal_1)));
+ Set_Is_Constrained (T);
Set_Is_Generic_Type (Base);
Set_Etype (Base, Base);
procedure Analyze_Formal_Package (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Formal : constant Entity_Id := Defining_Identifier (N);
+ Pack_Id : constant Entity_Id := Defining_Identifier (N);
+ Formal : Entity_Id;
Gen_Id : constant Node_Id := Name (N);
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
end if;
end if;
- -- Check for a formal package that is a package renaming.
+ -- Check for a formal package that is a package renaming
if Present (Renamed_Object (Gen_Unit)) then
Gen_Unit := Renamed_Object (Gen_Unit);
-- and analyze it like a regular package, except that we treat the
-- formals as additional visible components.
- Set_Instance_Env (Gen_Unit, Formal);
-
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
if In_Extended_Main_Source_Unit (N) then
Generate_Reference (Gen_Unit, N);
end if;
+ Formal := New_Copy (Pack_Id);
New_N :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
- Set_Defining_Unit_Name (Specification (New_N), Formal);
Rewrite (N, New_N);
+ Set_Defining_Unit_Name (Specification (New_N), Formal);
+ Set_Instance_Env (Gen_Unit, Formal);
Enter_Name (Formal);
Set_Ekind (Formal, E_Generic_Package);
Set_Ekind (Formal, E_Package);
Set_Generic_Parent (Specification (N), Gen_Unit);
Set_Has_Completion (Formal, True);
+
+ Set_Ekind (Pack_Id, E_Package);
+ Set_Etype (Pack_Id, Standard_Void_Type);
+ Set_Scope (Pack_Id, Scope (Formal));
+ Set_Has_Completion (Pack_Id, True);
end if;
end Analyze_Formal_Package;
begin
New_Private_Type (N, T, Def);
- -- Set the size to an arbitrary but legal value.
+ -- Set the size to an arbitrary but legal value
Set_Size_Info (T, Standard_Integer);
Set_RM_Size (T, RM_Size (Standard_Integer));
begin
Enter_Name (T);
- Set_Ekind (T, E_Signed_Integer_Subtype);
- Set_Etype (T, Base);
- Set_Size_Info (T, Standard_Integer);
- Set_RM_Size (T, RM_Size (Standard_Integer));
- Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
+ Set_Ekind (T, E_Signed_Integer_Subtype);
+ Set_Etype (T, Base);
+ Set_Size_Info (T, Standard_Integer);
+ Set_RM_Size (T, RM_Size (Standard_Integer));
+ Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
+ Set_Is_Constrained (T);
Set_Is_Generic_Type (Base);
Set_Size_Info (Base, Standard_Integer);
Set_Is_Formal_Subprogram (Nam);
Set_Has_Completion (Nam);
+ if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then
+ Set_Is_Abstract (Nam);
+ Set_Is_Dispatching_Operation (Nam);
+
+ declare
+ Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
+
+ begin
+ if not Present (Ctrl_Type) then
+ Error_Msg_N
+ ("abstract formal subprogram must have a controlling type",
+ N);
+
+ else
+ Check_Controlling_Formals (Ctrl_Type, Nam);
+ end if;
+ end;
+ end if;
+
-- Default name is resolved at the point of instantiation
if Box_Present (N) then
Defining_Identifier (First (Discriminant_Specifications (N))));
end if;
- -- Enter the new name, and branch to specific routine.
+ -- Enter the new name, and branch to specific routine
case Nkind (Def) is
when N_Formal_Private_Type_Definition =>
Id := Defining_Entity (N);
Generate_Definition (Id);
- -- Expansion is not applied to generic units.
+ -- Expansion is not applied to generic units
Start_Generic;
else
E := First_Entity (Gen_Unit);
-
while Present (E) loop
-
if Is_Subprogram (E)
and then Is_Inlined (E)
then
Text_IO_Kludge (Name (N));
- -- Make node global for error reporting.
+ -- Make node global for error reporting
Instantiation_Node := N;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
- -- Ada0Y (AI-50217): Instance can not be used in limited with_clause
+ -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
if From_With_Type (Gen_Unit) then
Error_Msg_N
Set_Entity (Gen_Id, Gen_Unit);
- -- If generic is a renaming, get original generic unit.
+ -- If generic is a renaming, get original generic unit
if Present (Renamed_Object (Gen_Unit))
and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
Gen_Unit := Renamed_Object (Gen_Unit);
end if;
- -- Verify that there are no circular instantiations.
+ -- Verify that there are no circular instantiations
if In_Open_Scopes (Gen_Unit) then
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
- -- Copy original generic tree, to produce text for instantiation.
+ -- Copy original generic tree, to produce text for instantiation
Act_Tree :=
Copy_Generic_Node
if Unit_Requires_Body (Scop) then
Enclosing_Body_Present := True;
exit;
+
+ elsif In_Open_Scopes (Scop)
+ and then In_Package_Body (Scop)
+ then
+ Enclosing_Body_Present := True;
+ exit;
end if;
exit when Is_Compilation_Unit (Scop);
and then Expander_Active
and then (not Is_Child_Unit (Gen_Unit)
or else not Is_Generic_Unit (Scope (Gen_Unit)))
- and then Is_In_Main_Unit (N)
+ and then (Is_In_Main_Unit (N)
+ or else In_Main_Context (Current_Scope))
and then Nkind (Parent (N)) /= N_Compilation_Unit
and then Might_Inline_Subp
and then not Is_Actual_Pack
-- If front_end_inlining is enabled, do not instantiate a
-- body if within a generic context.
- if Front_End_Inlining
- and then not Expander_Active
+ if (Front_End_Inlining
+ and then not Expander_Active)
+ or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
then
Needs_Body := False;
end if;
Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
- -- If this is the main unit, replace the main entity as well.
+ -- If this is the main unit, replace the main entity as well
if Current_Sem_Unit = Main_Unit then
Main_Unit_Entity := Act_Decl_Id;
end if;
end if;
+ -- There is a problem with inlining here.
+
Set_Unit (Parent (N), Act_Decl);
Set_Parent_Spec (Act_Decl, Parent_Spec (N));
Analyze (Act_Decl);
Inline_Instance_Body (N, Gen_Unit, Act_Decl);
end if;
+ -- The following is a tree patch for ASIS: ASIS needs separate nodes
+ -- to be used as defining identifiers for a formal package and for the
+ -- corresponding expanded package
+
+ if Nkind (N) = N_Formal_Package_Declaration then
+ Act_Decl_Id := New_Copy (Defining_Entity (N));
+ Set_Comes_From_Source (Act_Decl_Id, True);
+ Set_Is_Generic_Instance (Act_Decl_Id, False);
+ Set_Defining_Identifier (N, Act_Decl_Id);
+ end if;
+
exception
when Instantiation_Error =>
if Parent_Installed then
end if;
end Analyze_Package_Instantiation;
- ---------------------------
- -- Inline_Instance_Body --
- ---------------------------
+ --------------------------
+ -- Inline_Instance_Body --
+ --------------------------
procedure Inline_Instance_Body
(N : Node_Id;
New_Scope (Curr_Scope);
Set_Is_Immediately_Visible (Curr_Scope);
- -- Finally, restore inner scopes as well.
+ -- Finally, restore inner scopes as well
for J in reverse 1 .. Num_Inner loop
New_Scope (Inner_Scopes (J));
end if;
Restore_Scope_Stack (Handle_Use => False);
+
+ if Present (Curr_Scope)
+ and then
+ (In_Private_Part (Curr_Scope)
+ or else In_Package_Body (Curr_Scope))
+ then
+ -- Install private declaration of ancestor units, which
+ -- are currently available. Restore_Scope_Stack and
+ -- Install_Context only install the visible part of parents.
+
+ declare
+ Par : Entity_Id;
+ begin
+ Par := Scope (Curr_Scope);
+ while (Present (Par))
+ and then Par /= Standard_Standard
+ loop
+ Install_Private_Declarations (Par);
+ Par := Scope (Par);
+ end loop;
+ end;
+ end if;
end if;
- -- Restore use clauses. For a child unit, use clauses in the
- -- parents are restored when installing the context, so only
- -- those in inner scopes (and those local to the child unit itself)
- -- need to be installed explicitly.
+ -- Restore use clauses. For a child unit, use clauses in the parents
+ -- are restored when installing the context, so only those in inner
+ -- scopes (and those local to the child unit itself) need to be
+ -- installed explicitly.
if Is_Child_Unit (Curr_Unit)
and then Removed
Set_Is_Generic_Instance (Instances (J), True);
end loop;
- -- If generic unit is in current unit, current context is correct.
+ -- If generic unit is in current unit, current context is correct
else
Instantiate_Package_Body
Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
end if;
- -- The instance is not a freezing point for the new subprogram.
+ -- The instance is not a freezing point for the new subprogram
Set_Is_Frozen (Act_Decl_Id, False);
Text_IO_Kludge (Gen_Id);
- -- Make node global for error reporting.
+ -- Make node global for error reporting
Instantiation_Node := N;
Pre_Analyze_Actuals (N);
Set_Instance_Env (Gen_Unit, Empty);
- -- Initialize renamings map, for error checking.
+ -- Initialize renamings map, for error checking
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
- -- Copy original generic tree, to produce text for instantiation.
+ -- Copy original generic tree, to produce text for instantiation
Act_Tree :=
Copy_Generic_Node
or else Nkind (Assoc) = N_Extension_Aggregate
then
return Assoc;
+
else
-- If the node is part of an inner generic, it may itself have been
-- remapped into a further generic copy. Associated_Node is otherwise
Set_Library_Unit (Decl_Cunit, Body_Cunit);
Set_Library_Unit (Body_Cunit, Decl_Cunit);
- -- Preserve the private nature of the package if needed.
+ -- Preserve the private nature of the package if needed
Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
-- Common error routine for mismatch between the parameters of
-- the actual instance and those of the formal package.
+ function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
+ -- The formal may come from a nested formal package, and the actual
+ -- may have been constant-folded. To determine whether the two denote
+ -- the same entity we may have to traverse several definitions to
+ -- recover the ultimate entity that they refer to.
+
+ function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
+ -- Similarly, if the formal comes from a nested formal package, the
+ -- actual may designate the formal through multiple renamings, which
+ -- have to be followed to determine the original variable in question.
+
+ --------------------
+ -- Check_Mismatch --
+ --------------------
+
procedure Check_Mismatch (B : Boolean) is
begin
if B then
end if;
end Check_Mismatch;
+ --------------------------------
+ -- Same_Instantiated_Constant --
+ --------------------------------
+
+ function Same_Instantiated_Constant
+ (E1, E2 : Entity_Id) return Boolean
+ is
+ Ent : Entity_Id;
+ begin
+ Ent := E2;
+ while Present (Ent) loop
+ if E1 = Ent then
+ return True;
+
+ elsif Ekind (Ent) /= E_Constant then
+ return False;
+
+ elsif Is_Entity_Name (Constant_Value (Ent)) then
+ if Entity (Constant_Value (Ent)) = E1 then
+ return True;
+ else
+ Ent := Entity (Constant_Value (Ent));
+ end if;
+
+ -- The actual may be a constant that has been folded. Recover
+ -- original name.
+
+ elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
+ Ent := Entity (Original_Node (Constant_Value (Ent)));
+ else
+ return False;
+ end if;
+ end loop;
+
+ return False;
+ end Same_Instantiated_Constant;
+
+ --------------------------------
+ -- Same_Instantiated_Variable --
+ --------------------------------
+
+ function Same_Instantiated_Variable
+ (E1, E2 : Entity_Id) return Boolean
+ is
+ function Original_Entity (E : Entity_Id) return Entity_Id;
+ -- Follow chain of renamings to the ultimate ancestor
+
+ ---------------------
+ -- Original_Entity --
+ ---------------------
+
+ function Original_Entity (E : Entity_Id) return Entity_Id is
+ Orig : Entity_Id;
+
+ begin
+ Orig := E;
+ while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
+ and then Present (Renamed_Object (Orig))
+ and then Is_Entity_Name (Renamed_Object (Orig))
+ loop
+ Orig := Entity (Renamed_Object (Orig));
+ end loop;
+
+ return Orig;
+ end Original_Entity;
+
+ -- Start of processing for Same_Instantiated_Variable
+
+ begin
+ return Ekind (E1) = Ekind (E2)
+ and then Original_Entity (E1) = Original_Entity (E2);
+ end Same_Instantiated_Variable;
+
-- Start of processing for Check_Formal_Package_Instance
begin
if Is_Entity_Name (Expr2) then
if Entity (Expr1) = Entity (Expr2) then
null;
-
- elsif Ekind (Entity (Expr2)) = E_Constant
- and then Is_Entity_Name (Constant_Value (Entity (Expr2)))
- and then
- Entity (Constant_Value (Entity (Expr2))) = Entity (Expr1)
- then
- null;
else
- Check_Mismatch (True);
+ Check_Mismatch
+ (not Same_Instantiated_Constant
+ (Entity (Expr1), Entity (Expr2)));
end if;
else
Check_Mismatch (True);
end if;
+ elsif Is_Entity_Name (Original_Node (Expr1))
+ and then Is_Entity_Name (Expr2)
+ and then
+ Same_Instantiated_Constant
+ (Entity (Original_Node (Expr1)), Entity (Expr2))
+ then
+ null;
+
elsif Nkind (Expr1) = N_Null then
Check_Mismatch (Nkind (Expr1) /= N_Null);
Check_Mismatch (True);
end if;
- elsif Ekind (E1) = E_Variable
- or else Ekind (E1) = E_Package
- then
+ elsif Ekind (E1) = E_Variable then
+ Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
+
+ elsif Ekind (E1) = E_Package then
Check_Mismatch
(Ekind (E1) /= Ekind (E2)
or else Renamed_Object (E1) /= Renamed_Object (E2));
E : Entity_Id;
Astype : Entity_Id;
+ function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean;
+ -- For a formal that is an array type, the component type is often
+ -- a previous formal in the same unit. The privacy status of the
+ -- component type will have been examined earlier in the traversal
+ -- of the corresponding actuals, and this status should not be
+ -- modified for the array type itself.
+ -- To detect this case we have to rescan the list of formals, which
+ -- is usually short enough to ignore the resulting inefficiency.
+
+ function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
+ Prev : Entity_Id;
+ begin
+ Prev := First_Entity (Instance);
+ while Present (Prev) loop
+ if Is_Type (Prev)
+ and then Nkind (Parent (Prev)) = N_Subtype_Declaration
+ and then Is_Entity_Name (Subtype_Indication (Parent (Prev)))
+ 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;
+
+ -- Start of processing for Check_Generic_Actuals
+
begin
E := First_Entity (Instance);
while Present (E) loop
and then Scope (Etype (E)) /= Instance
and then Is_Entity_Name (Subtype_Indication (Parent (E)))
then
- Check_Private_View (Subtype_Indication (Parent (E)));
+ if Is_Array_Type (E)
+ and then Denotes_Previous_Actual (Component_Type (E))
+ then
+ null;
+ 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,
+ In_Use (Instance));
-- We constructed the generic actual type as a subtype of
-- the supplied type. This means that it normally would not
elsif Denotes_Formal_Package (E) then
null;
- elsif Present (Associated_Formal_Package (E))
- and then Box_Present (Parent (Associated_Formal_Package (E)))
- then
- Check_Generic_Actuals (Renamed_Object (E), True);
+ elsif Present (Associated_Formal_Package (E)) then
+ if Box_Present (Parent (Associated_Formal_Package (E))) then
+ Check_Generic_Actuals (Renamed_Object (E), True);
+ end if;
+
Set_Is_Hidden (E, False);
end if;
function Find_Generic_Child
(Scop : Entity_Id;
- Id : Node_Id)
- return Entity_Id;
- -- Search generic parent for possible child unit with the given name.
+ Id : Node_Id) return Entity_Id;
+ -- Search generic parent for possible child unit with the given name
function In_Enclosing_Instance return Boolean;
-- Within an instance of the parent, the child unit may be denoted
function Find_Generic_Child
(Scop : Entity_Id;
- Id : Node_Id)
- return Entity_Id
+ Id : Node_Id) return Entity_Id
is
E : Entity_Id;
Set_Entity (S, E);
Set_Etype (S, Etype (E));
- -- Indicate that this is a reference to the parent.
+ -- Indicate that this is a reference to the parent
if In_Extended_Main_Source_Unit (Gen_Id) then
Set_Is_Instantiated (Inst_Par);
function Contains_Instance_Of
(Inner : Entity_Id;
Outer : Entity_Id;
- N : Node_Id)
- return Boolean
+ N : Node_Id) return Boolean
is
Elmt : Elmt_Id;
Scop : Entity_Id;
Next_Elmt (Elmt);
end loop;
- -- Indicate that Inner is being instantiated within Scop.
+ -- Indicate that Inner is being instantiated within Scop
Append_Elmt (Inner, Inner_Instances (Scop));
end if;
function Copy_Generic_Node
(N : Node_Id;
Parent_Id : Node_Id;
- Instantiating : Boolean)
- return Node_Id
+ Instantiating : Boolean) return Node_Id
is
Ent : Entity_Id;
New_N : Node_Id;
-- value (Sloc, Uint, Char) in which case it need not be copied.
procedure Copy_Descendants;
- -- Common utility for various nodes.
+ -- Common utility for various nodes
function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
- -- Make copy of element list.
+ -- Make copy of element list
function Copy_Generic_List
(L : List_Id;
- Parent_Id : Node_Id)
- return List_Id;
- -- Apply Copy_Node recursively to the members of a node list.
+ Parent_Id : Node_Id) return List_Id;
+ -- Apply Copy_Node recursively to the members of a node list
function In_Defining_Unit_Name (Nam : Node_Id) return Boolean;
-- True if an identifier is part of the defining program unit name
-- (for ASIS use) even though as the name of an enclosing generic
-- it would otherwise not be preserved in the generic tree.
- -----------------------
- -- Copy_Descendants --
- -----------------------
+ ----------------------
+ -- Copy_Descendants --
+ ----------------------
procedure Copy_Descendants is
function Copy_Generic_List
(L : List_Id;
- Parent_Id : Node_Id)
- return List_Id
+ Parent_Id : Node_Id) return List_Id
is
N : Node_Id;
New_L : List_Id;
begin
if Present (T) then
- -- Retrieve the allocator node in the generic copy.
+ -- Retrieve the allocator node in the generic copy
Acc_T := Etype (Parent (Parent (T)));
if Present (Acc_T)
-- Denotes_Formal_Package --
----------------------------
- function Denotes_Formal_Package (Pack : Entity_Id) return Boolean is
- Par : constant Entity_Id := Current_Instantiated_Parent.Act_Id;
+ function Denotes_Formal_Package
+ (Pack : Entity_Id;
+ On_Exit : Boolean := False) return Boolean
+ is
+ Par : Entity_Id;
Scop : constant Entity_Id := Scope (Pack);
E : Entity_Id;
begin
+ if On_Exit then
+ Par :=
+ Instance_Envs.Table
+ (Instance_Envs.Last).Instantiated_Parent.Act_Id;
+ else
+ Par := Current_Instantiated_Parent.Act_Id;
+ end if;
+
if Ekind (Scop) = E_Generic_Package
or else Nkind (Unit_Declaration_Node (Scop)) =
N_Generic_Subprogram_Declaration
function Find_Actual_Type
(Typ : Entity_Id;
- Gen_Scope : Entity_Id)
- return Entity_Id
+ Gen_Scope : Entity_Id) return Entity_Id
is
T : Entity_Id;
-- node for it.
function True_Parent (N : Node_Id) return Node_Id;
- -- For a subunit, return parent of corresponding stub.
+ -- For a subunit, return parent of corresponding stub
-------------
-- Earlier --
P2 : Node_Id := N2;
procedure Find_Depth (P : in out Node_Id; D : in out Integer);
- -- Find distance from given node to enclosing compilation unit.
+ -- Find distance from given node to enclosing compilation unit
----------------
-- Find_Depth --
Saved : Instance_Env;
begin
- Saved.Ada_83 := Ada_83;
+ Saved.Ada_Version := Ada_Version;
Saved.Instantiated_Parent := Current_Instantiated_Parent;
Saved.Exchanged_Views := Exchanged_Views;
Saved.Hidden_Entities := Hidden_Entities;
Saved.Current_Sem_Unit := Current_Sem_Unit;
+ Saved.Parent_Unit_Visible := Parent_Unit_Visible;
Instance_Envs.Increment_Last;
Instance_Envs.Table (Instance_Envs.Last) := Saved;
function In_Same_Declarative_Part
(F_Node : Node_Id;
- Inst : Node_Id)
- return Boolean
+ Inst : Node_Id) return Boolean
is
Decls : constant Node_Id := Parent (F_Node);
Nod : Node_Id := Parent (Inst);
end In_Same_Declarative_Part;
---------------------
+ -- In_Main_Context --
+ ---------------------
+
+ function In_Main_Context (E : Entity_Id) return Boolean is
+ Context : List_Id;
+ Clause : Node_Id;
+ Nam : Node_Id;
+
+ begin
+ if not Is_Compilation_Unit (E)
+ or else Ekind (E) /= E_Package
+ or else In_Private_Part (E)
+ then
+ return False;
+ end if;
+
+ Context := Context_Items (Cunit (Main_Unit));
+
+ Clause := First (Context);
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause then
+ Nam := Name (Clause);
+
+ -- If the current scope is part of the context of the main unit,
+ -- analysis of the corresponding with_clause is not complete, and
+ -- the entity is not set. We use the Chars field directly, which
+ -- might produce false positives in rare cases, but guarantees
+ -- that we produce all the instance bodies we will need.
+
+ if (Nkind (Nam) = N_Identifier
+ 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;
+ end if;
+
+ Next (Clause);
+ end loop;
+
+ return False;
+ end In_Main_Context;
+
+ ---------------------
-- Inherit_Context --
---------------------
Must_Delay : Boolean;
function Enclosing_Subp (Id : Entity_Id) return Entity_Id;
- -- Find subprogram (if any) that encloses instance and/or generic body.
+ -- Find subprogram (if any) that encloses instance and/or generic body
function True_Sloc (N : Node_Id) return Source_Ptr;
-- If the instance is nested inside a generic unit, the Sloc of the
-- point of the current enclosing instance. Pending a better usage of
-- Slocs to indicate instantiation places, we determine the place of
-- origin of a node by finding the maximum sloc of any ancestor node.
- -- Why is this not equivalent fo Top_Level_Location ???
+ -- Why is this not equivalent to Top_Level_Location ???
+
+ --------------------
+ -- Enclosing_Subp --
+ --------------------
function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
Scop : Entity_Id := Scope (Id);
return Scop;
end Enclosing_Subp;
+ ---------------
+ -- True_Sloc --
+ ---------------
+
function True_Sloc (N : Node_Id) return Source_Ptr is
Res : Source_Ptr;
N1 : Node_Id;
-- for the unit itself.
procedure Install_Noninstance_Specs (Par : Entity_Id);
- -- Install the scopes of noninstance parent units ending with Par.
+ -- Install the scopes of noninstance parent units ending with Par
procedure Install_Spec (Par : Entity_Id);
-- The child unit is within the declarative part of the parent, so
begin
E := First_Entity (Par);
-
while Present (E) loop
-
if Ekind (E) = E_Package
and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
then
- -- If this is the renaming for the parent instance, done.
+ -- If this is the renaming for the parent instance, done
if Renamed_Object (E) = Par then
exit;
Specification (Unit_Declaration_Node (Par));
begin
+ if not Is_Child_Unit (Par) then
+ Parent_Unit_Visible := Is_Immediately_Visible (Par);
+ end if;
+
New_Scope (Par);
Set_Is_Immediately_Visible (Par);
Install_Visible_Declarations (Par);
function Instantiate_Formal_Package
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
- return List_Id
+ Analyzed_Formal : Node_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Actual);
Actual_Pack : Entity_Id;
function Formal_Entity
(F : Node_Id;
- Act_Ent : Entity_Id)
- return Entity_Id;
+ Act_Ent : Entity_Id) return Entity_Id;
-- Returns the entity associated with the given formal F. In the
-- case where F is a formal package, this function will iterate
-- through all of F's formals and enter map associations from the
function Is_Instance_Of
(Act_Spec : Entity_Id;
- Gen_Anc : Entity_Id)
- return Boolean;
+ Gen_Anc : Entity_Id) return Boolean;
-- The actual can be an instantiation of a generic within another
-- instance, in which case there is no direct link from it to the
-- original generic ancestor. In that case, we recognize that the
-- that the entities in P2 are mapped into those of P3. The mapping of
-- entities has to be done recursively for nested packages.
+ procedure Process_Nested_Formal (Formal : Entity_Id);
+ -- If the current formal is declared with a box, its own formals are
+ -- visible in the instance, as they were in the generic, and their
+ -- Hidden flag must be reset. If some of these formals are themselves
+ -- packages declared with a box, the processing must be recursive.
+
--------------------------
-- Find_Matching_Actual --
--------------------------
end loop;
when others =>
- null;
- pragma Assert (False);
+ raise Program_Error;
end case;
end Find_Matching_Actual;
function Formal_Entity
(F : Node_Id;
- Act_Ent : Entity_Id)
- return Entity_Id
+ Act_Ent : Entity_Id) return Entity_Id
is
Orig_Node : Node_Id := F;
Act_Pkg : Entity_Id;
while Present (Actual_Ent)
and then Present (Formal_Node)
- and then Actual_Ent /= First_Private_Entity (Act_Ent)
+ and then Actual_Ent /= First_Private_Entity (Act_Pkg)
loop
-- ??? Are the following calls also needed here:
--
function Is_Instance_Of
(Act_Spec : Entity_Id;
- Gen_Anc : Entity_Id)
- return Boolean
+ Gen_Anc : Entity_Id) return Boolean
is
Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
if No (Gen_Par) then
return False;
- -- Simplest case: the generic parent of the actual is the formal.
+ -- Simplest case: the generic parent of the actual is the formal
elsif Gen_Par = Gen_Anc then
return True;
end loop;
end Map_Entities;
+ ---------------------------
+ -- Process_Nested_Formal --
+ ---------------------------
+
+ procedure Process_Nested_Formal (Formal : Entity_Id) is
+ Ent : Entity_Id;
+
+ begin
+ if Present (Associated_Formal_Package (Formal))
+ and then Box_Present (Parent (Associated_Formal_Package (Formal)))
+ then
+ Ent := First_Entity (Formal);
+ while Present (Ent) loop
+ Set_Is_Hidden (Ent, False);
+ Set_Is_Potentially_Use_Visible
+ (Ent, Is_Potentially_Use_Visible (Formal));
+
+ if Ekind (Ent) = E_Package then
+ exit when Renamed_Entity (Ent) = Renamed_Entity (Formal);
+ Process_Nested_Formal (Ent);
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end if;
+ end Process_Nested_Formal;
+
-- Start of processing for Instantiate_Formal_Package
begin
Set_Is_Potentially_Use_Visible
(Actual_Ent, In_Use (Actual_Pack));
+ if Ekind (Actual_Ent) = E_Package then
+ Process_Nested_Formal (Actual_Ent);
+ end if;
+
if Present (Formal_Node) then
Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
Next_Non_Pragma (Formal_Node);
else
- -- No further formals to match.
+ -- No further formals to match, but the generic
+ -- part may contain inherited operation that are
+ -- not hidden in the enclosing instance.
- exit;
+ Next_Entity (Actual_Ent);
end if;
end loop;
function Instantiate_Formal_Subprogram
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
- return Node_Id
+ Analyzed_Formal : Node_Id) return Node_Id
is
Loc : Source_Ptr := Sloc (Instantiation_Node);
Formal_Sub : constant Entity_Id :=
New_Spec : Node_Id;
function From_Parent_Scope (Subp : Entity_Id) return Boolean;
- -- If the generic is a child unit, the parent has been installed
- -- on the scope stack, but a default subprogram cannot resolve to
- -- something on the parent because that parent is not really part
- -- of the visible context (it is there to resolve explicit local
- -- entities). If the default has resolved in this way, we remove
- -- the entity from immediate visibility and analyze the node again
- -- to emit an error message or find another visible candidate.
+ -- If the generic is a child unit, the parent has been installed on the
+ -- scope stack, but a default subprogram cannot resolve to something on
+ -- the parent because that parent is not really part of the visible
+ -- context (it is there to resolve explicit local entities). If the
+ -- default has resolved in this way, we remove the entity from
+ -- immediate visibility and analyze the node again to emit an error
+ -- message or find another visible candidate.
procedure Valid_Actual_Subprogram (Act : Node_Id);
- -- Perform legality check and raise exception on failure.
+ -- Perform legality check and raise exception on failure
-----------------------
-- From_Parent_Scope --
begin
New_Spec := New_Copy_Tree (Specification (Formal));
- -- Create new entity for the actual (New_Copy_Tree does not).
+ -- Create new entity for the actual (New_Copy_Tree does not)
Set_Defining_Unit_Name
(New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
Decl_Node :=
Make_Subprogram_Renaming_Declaration (Loc,
Specification => New_Spec,
- Name => Nam);
+ Name => Nam);
+
+ -- If we do not have an actual and the formal specified <> then
+ -- set to get proper default.
+
+ if No (Actual) and then Box_Present (Formal) then
+ Set_From_Default (Decl_Node);
+ end if;
-- Gather possible interpretations for the actual before analyzing the
-- instance. If overloaded, it will be resolved when analyzing the
-- The generic instantiation freezes the actual. This can only be
-- done once the actual is resolved, in the analysis of the renaming
- -- declaration. To indicate that must be done, we set the corresponding
- -- spec of the node to point to the formal subprogram entity.
+ -- declaration. To make the formal subprogram entity available, we set
+ -- Corresponding_Formal_Spec to point to the formal subprogram entity.
+ -- This is also needed in Analyze_Subprogram_Renaming for the processing
+ -- of formal abstract subprograms.
- Set_Corresponding_Spec (Decl_Node, Analyzed_S);
+ Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S);
-- We cannot analyze the renaming declaration, and thus find the
-- actual, until the all the actuals are assembled in the instance.
function Instantiate_Object
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
- return List_Id
+ Analyzed_Formal : Node_Id) return List_Id
is
Formal_Id : constant Entity_Id := Defining_Identifier (Formal);
Type_Id : constant Node_Id := Subtype_Mark (Formal);
Subt_Decl : Node_Id := Empty;
begin
- -- Sloc for error message on missing actual.
+ -- Sloc for error message on missing actual
+
Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal)));
if Get_Instance_Of (Formal_Id) /= Formal_Id then
if Out_Present (Formal) then
- -- An IN OUT generic actual must be a name. The instantiation is
- -- a renaming declaration. The actual is the name being renamed.
- -- We use the actual directly, rather than a copy, because it is not
+ -- An IN OUT generic actual must be a name. The instantiation is a
+ -- renaming declaration. The actual is the name being renamed. We
+ -- use the actual directly, rather than a copy, because it is not
-- used further in the list of actuals, and because a copy or a use
- -- of relocate_node is incorrect if the instance is nested within
- -- a generic. In order to simplify ASIS searches, the Generic_Parent
+ -- of relocate_node is incorrect if the instance is nested within a
+ -- generic. In order to simplify ASIS searches, the Generic_Parent
-- field links the declaration to the generic association.
if No (Actual) then
Append (Decl_Node, List);
Analyze (Actual);
+ -- Return if the analysis of the actual reported some error
+
+ if Etype (Actual) = Any_Type then
+ return List;
+ end if;
+
-- This check is performed here because Analyze_Object_Renaming
-- will not check it when Comes_From_Source is False. Note
-- though that the check for the actual being the name of an
if Nkind (Actual) /= N_Allocator then
Analyze (Actual);
+
+ -- Return if the analysis of the actual reported some error
+
+ if Etype (Actual) = Any_Type then
+ return List;
+ end if;
end if;
declare
begin
Freeze_Before (Instantiation_Node, Typ);
- -- If the actual is an aggregate, perform name resolution
- -- on its components (the analysis of an aggregate does not
- -- do it) to capture local names that may be hidden if the
+ -- If the actual is an aggregate, perform name resolution on
+ -- its components (the analysis of an aggregate does not do
+ -- it) to capture local names that may be hidden if the
-- generic is a child unit.
if Nkind (Actual) = N_Aggregate then
elsif Present (Expression (Formal)) then
- -- Use default to construct declaration.
+ -- Use default to construct declaration
Decl_Node :=
Make_Object_Declaration (Sloc (Formal),
if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
-- Either body is not present, or context is non-expanding, as
- -- when compiling a subunit. Mark the instance as completed.
+ -- when compiling a subunit. Mark the instance as completed, and
+ -- diagnose a missing body when needed.
+
+ if Expander_Active
+ and then Operating_Mode = Generate_Code
+ then
+ Error_Msg_N
+ ("missing proper body for instantiation", Gen_Body);
+ end if;
Set_Has_Completion (Anon_Id);
return;
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id;
- Actual_Decls : List_Id)
- return Node_Id
+ Actual_Decls : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Actual);
Gen_T : constant Entity_Id := Defining_Identifier (Formal);
function Formal_Dimensions return Int;
-- Count number of dimensions in array type formal
+ -----------------------
+ -- Formal_Dimensions --
+ -----------------------
+
function Formal_Dimensions return Int is
Num : Int := 0;
Index : Node_Id;
-- actual must correspond to a discriminant of the formal.
elsif Has_Discriminants (Act_T)
+ and then not Has_Unknown_Discriminants (Act_T)
and then Has_Discriminants (Ancestor)
then
Actual_Discr := First_Discriminant (Act_T);
-- for constrainedness, but the check here is added for
-- completeness.
- elsif Has_Discriminants (Act_T) then
+ elsif Has_Discriminants (Act_T)
+ and then not Has_Unknown_Discriminants (Act_T)
+ then
Error_Msg_NE
("actual for & must not have discriminants", Actual, Gen_T);
Abandon_Instantiation (Actual);
elsif Is_Indefinite_Subtype (Act_T)
and then not Is_Indefinite_Subtype (A_Gen_T)
- and then Ada_95
+ and then Ada_Version >= Ada_95
then
Error_Msg_NE
("actual for & must be a definite subtype", Actual, Gen_T);
Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
- -- access discriminants match if designated types do.
+ -- Access discriminants match if designated types do
if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
- and then (Ekind (Base_Type (Etype (Actual_Discr))))
- = E_Anonymous_Access_Type
- and then Get_Instance_Of (
- Designated_Type (Base_Type (Formal_Subt)))
- = Designated_Type (Base_Type (Etype (Actual_Discr)))
+ and then (Ekind (Base_Type (Etype (Actual_Discr)))) =
+ E_Anonymous_Access_Type
+ and then
+ Get_Instance_Of
+ (Designated_Type (Base_Type (Formal_Subt))) =
+ Designated_Type (Base_Type (Etype (Actual_Discr)))
then
null;
elsif Base_Type (Formal_Subt) /=
- Base_Type (Etype (Actual_Discr))
+ Base_Type (Etype (Actual_Discr))
then
Error_Msg_NE
("types of actual discriminants must match formal",
elsif not Subtypes_Statically_Match
(Formal_Subt, Etype (Actual_Discr))
- and then Ada_95
+ and then Ada_Version >= Ada_95
then
Error_Msg_NE
("subtypes of actual discriminants must match formal",
else
Act_T := Entity (Actual);
+ -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
+ -- as a generic actual parameter if the corresponding formal type
+ -- does not have a known_discriminant_part, or is a formal derived
+ -- type that is an Unchecked_Union type.
+
+ if Is_Unchecked_Union (Base_Type (Act_T)) then
+ if not Has_Discriminants (A_Gen_T)
+ or else
+ (Is_Derived_Type (A_Gen_T)
+ and then
+ Is_Unchecked_Union (A_Gen_T))
+ then
+ null;
+ else
+ Error_Msg_N ("Unchecked_Union cannot be the actual for a" &
+ " discriminated formal type", Act_T);
+
+ end if;
+ end if;
+
-- Deal with fixed/floating restrictions
if Is_Floating_Point_Type (Act_T) then
---------------------
function Is_In_Main_Unit (N : Node_Id) return Boolean is
- Unum : constant Unit_Number_Type := Get_Source_Unit (N);
-
+ Unum : constant Unit_Number_Type := Get_Source_Unit (N);
Current_Unit : Node_Id;
begin
and then P /= Current_Scope
then
-- We are within an instance of some sibling. Retain
- -- visibility of parent, for proper subsequent cleanup.
+ -- visibility of parent, for proper subsequent cleanup,
+ -- and reinstall private declarations as well.
Set_In_Private_Part (P);
+ Install_Private_Declarations (P);
end if;
- elsif not In_Open_Scopes (Scope (P)) then
+ -- If the ultimate parent is a compilation unit, reset its
+ -- visibility to what it was before instantiation.
+
+ elsif not In_Open_Scopes (Scope (P))
+ or else
+ (not Is_Child_Unit (P) and then not Parent_Unit_Visible)
+ then
Set_Is_Immediately_Visible (P, False);
end if;
end loop;
- -- Reset visibility of entities in the enclosing scope.
+ -- Reset visibility of entities in the enclosing scope
Set_Is_Hidden_Open_Scope (Current_Scope, False);
Hidden := First_Elmt (Hidden_Entities);
Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
begin
- Ada_83 := Saved.Ada_83;
+ Ada_Version := Saved.Ada_Version;
if No (Current_Instantiated_Parent.Act_Id) then
Exchanged_Views := Saved.Exchanged_Views;
Hidden_Entities := Saved.Hidden_Entities;
Current_Sem_Unit := Saved.Current_Sem_Unit;
+ Parent_Unit_Visible := Saved.Parent_Unit_Visible;
Instance_Envs.Decrement_Last;
end Restore_Env;
Dep_Elmt : Elmt_Id;
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.
+
+ procedure Restore_Nested_Formal (Formal : Entity_Id) is
+ Ent : Entity_Id;
+ begin
+ if Present (Renamed_Object (Formal))
+ and then Denotes_Formal_Package (Renamed_Object (Formal), True)
+ then
+ return;
+
+ elsif Present (Associated_Formal_Package (Formal))
+ and then Box_Present (Parent (Associated_Formal_Package (Formal)))
+ then
+ Ent := First_Entity (Formal);
+
+ while Present (Ent) loop
+ exit when Ekind (Ent) = E_Package
+ and then Renamed_Entity (Ent) = Renamed_Entity (Formal);
+
+ Set_Is_Hidden (Ent);
+ Set_Is_Potentially_Use_Visible (Ent, False);
+
+ -- If package, then recurse
+
+ if Ekind (Ent) = E_Package then
+ Restore_Nested_Formal (Ent);
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end if;
+ end Restore_Nested_Formal;
+
begin
M := First_Elmt (Exchanged_Views);
while Present (M) loop
-- If the actual is itself a formal package for the enclosing
-- generic, or the actual for such a formal package, it remains
- -- visible after the current instance, and therefore nothing
+ -- visible on exit from the instance, and therefore nothing
-- needs to be done either, except to keep it accessible.
if Is_Package
elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
null;
- elsif Denotes_Formal_Package (Renamed_Object (E)) then
+ elsif Denotes_Formal_Package (Renamed_Object (E), True) then
Set_Is_Hidden (E, False);
else
while Present (Id)
and then Id /= First_Private_Entity (Act_P)
loop
- Set_Is_Hidden (Id, True);
- Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
exit when Ekind (Id) = E_Package
and then Renamed_Object (Id) = Act_P;
+ Set_Is_Hidden (Id, True);
+ Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
+
+ if Ekind (Id) = E_Package then
+ Restore_Nested_Formal (Id);
+ end if;
+
Next_Entity (Id);
end loop;
end;
- null;
end if;
end if;
-- the current scope (e.g. when the instance appears within the body
-- of an ancestor).
+ ----------------------
+ -- Is_Instance_Node --
+ ----------------------
+
function Is_Instance_Node (Decl : Node_Id) return Boolean is
begin
return (Nkind (Decl) in N_Generic_Instantiation
Next (Act2);
end loop;
- -- Find the associations added for default suprograms.
+ -- Find the associations added for default suprograms
if Present (Act2) then
while Nkind (Act2) /= N_Generic_Association
-- inlining.
Rewrite (N, New_Copy (N2));
- Set_Associated_Node (N, N2);
Set_Analyzed (N, False);
end if;
end if;
-- access to a composite type, or a parameterless function
-- call that returns an access type.
- -- Check whether corresponding entity in prefix is global.
+ -- Check whether corresponding entity in prefix is global
if Is_Entity_Name (Prefix (N2))
and then Present (Entity (Prefix (N2)))
begin
-- Regardless of the current mode, predefined units are analyzed in
- -- Ada95 mode, and Ada83 checks don't apply.
+ -- the most current Ada mode, and earlier version Ada checks do not
+ -- apply to predefined units.
if Is_Internal_File_Name
(Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
Renamings_Included => True) then
- Ada_83 := False;
+ Ada_Version := Ada_Version_Type'Last;
end if;
Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
OSDN Git Service
