-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
+with Exp_Disp; use Exp_Disp;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Freeze; use Freeze;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Elab; use Sem_Elab;
with Sem_Elim; use Sem_Elim;
-- are not accessible outside of the instance.
-- In a generic, a formal package is treated like a special instantiation.
- -- Our Ada95 compiler handled formals with and without box in different
+ -- Our Ada 95 compiler handled formals with and without box in different
-- ways. With partial parametrization, we use a single model for both.
-- We create a package declaration that consists of the specification of
-- the generic package, and a set of declarations that map the actuals
Def : Node_Id);
-- Creates a new private type, which does not require completion
+ procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id);
+ -- Ada 2012: Creates a new incomplete type whose actual does not freeze
+
procedure Analyze_Generic_Formal_Part (N : Node_Id);
+ -- Analyze generic formal part
procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
-- Create a new access type with the given designated type
-- package cannot be inlined by the front-end because front-end inlining
-- requires a strict linear order of elaboration.
+ function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id;
+ -- Check if some association between formals and actuals requires to make
+ -- visible primitives of a tagged type, and make those primitives visible.
+ -- Return the list of primitives whose visibility is modified (to restore
+ -- their visibility later through Restore_Hidden_Primitives). If no
+ -- candidate is found then return No_Elist.
+
procedure Check_Hidden_Child_Unit
(N : Node_Id;
Gen_Unit : Entity_Id;
-- an instantiation in the source, or the internal instantiation that
-- corresponds to the actual for a formal package.
+ function Earlier (N1, N2 : Node_Id) return Boolean;
+ -- Yields True if N1 and N2 appear in the same compilation unit,
+ -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
+ -- traversal of the tree for the unit. Used to determine the placement
+ -- of freeze nodes for instance bodies that may depend on other instances.
+
function Find_Actual_Type
(Typ : Entity_Id;
Gen_Type : Entity_Id) return Entity_Id;
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 subprograms 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.
+ -- vening subprograms or concurrent units. Used to find the proper plave
+ -- for the freeze node of an instance, when the generic is declared in a
+ -- previous instance. If predicate is true, the freeze node of the instance
+ -- can be placed after the freeze node of the previous instance, Otherwise
+ -- it has to be placed at the end of the current declarative part.
function In_Main_Context (E : Entity_Id) return Boolean;
-- Check whether an instantiation is in the context of the main unit.
-- of packages that are early instantiations are delayed, and their freeze
-- node appears after the generic body.
- procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id);
- -- Insert freeze node at the end of the declarative part that includes the
- -- instance node N. If N is in the visible part of an enclosing package
- -- declaration, the freeze node has to be inserted at the end of the
- -- private declarations, if any.
+ procedure Insert_Freeze_Node_For_Instance
+ (N : Node_Id;
+ F_Node : Node_Id);
+ -- N denotes a package or a subprogram instantiation and F_Node is the
+ -- associated freeze node. Insert the freeze node before the first source
+ -- body which follows immediately after N. If no such body is found, the
+ -- freeze node is inserted at the end of the declarative region which
+ -- contains N.
procedure Freeze_Subprogram_Body
(Inst_Node : Node_Id;
procedure Remove_Parent (In_Body : Boolean := False);
-- Reverse effect after instantiation of child is complete
+ procedure Install_Hidden_Primitives
+ (Prims_List : in out Elist_Id;
+ Gen_T : Entity_Id;
+ Act_T : Entity_Id);
+ -- Remove suffix 'P' from hidden primitives of Act_T to match the
+ -- visibility of primitives of Gen_T. The list of primitives to which
+ -- the suffix is removed is added to Prims_List to restore them later.
+
+ procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id);
+ -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
+ -- set to No_Elist.
+
procedure Inline_Instance_Body
(N : Node_Id;
Gen_Unit : Entity_Id;
-- before installing parents of generics, that are not visible for the
-- actuals themselves.
+ function True_Parent (N : Node_Id) return Node_Id;
+ -- For a subunit, return parent of corresponding stub, else return
+ -- parent of node.
+
procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
-- Verify that an attribute that appears as the default for a formal
-- subprogram is a function or procedure with the correct profile.
Formals : List_Id;
F_Copy : List_Id) return List_Id
is
-
- Actual_Types : constant Elist_Id := New_Elmt_List;
- Assoc : constant List_Id := New_List;
- Default_Actuals : constant Elist_Id := New_Elmt_List;
- Gen_Unit : constant Entity_Id :=
- Defining_Entity (Parent (F_Copy));
+ Actuals_To_Freeze : constant Elist_Id := New_Elmt_List;
+ Assoc : constant List_Id := New_List;
+ Default_Actuals : 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;
- Next_Formal : Node_Id;
- Temp_Formal : Node_Id;
Analyzed_Formal : Node_Id;
+ First_Named : Node_Id := Empty;
+ Formal : Node_Id;
Match : Node_Id;
Named : Node_Id;
- First_Named : Node_Id := Empty;
+ Saved_Formal : Node_Id;
Default_Formals : constant List_Id := New_List;
-- If an Others_Choice is present, some of the formals may be defaulted.
Num_Actuals : Int := 0;
Others_Present : Boolean := False;
+ Others_Choice : Node_Id := Empty;
-- In Ada 2005, indicates partial parametrization of a formal
-- package. As usual an other association must be last in the list.
+ procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
+ -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
+ -- cannot have a named association for it. AI05-0025 extends this rule
+ -- to formals of formal packages by AI05-0025, and it also applies to
+ -- box-initialized formals.
+
+ function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean;
+ -- Determine whether the parameter types and the return type of Subp
+ -- are fully defined at the point of instantiation.
+
function Matching_Actual
(F : Entity_Id;
A_F : Entity_Id) return Node_Id;
-- are named, scan the parameter associations to find the right one.
-- A_F is the corresponding entity in the analyzed generic,which is
-- placed on the selector name for ASIS use.
-
+ --
-- In Ada 2005, a named association may be given with a box, in which
-- case Matching_Actual sets Found_Assoc to the generic association,
-- but return Empty for the actual itself. In this case the code below
-- associations, and add an explicit box association for F if there
-- is none yet, and the default comes from an Others_Choice.
+ function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean;
+ -- Determine whether Subp renames one of the subprograms defined in the
+ -- generated package Standard.
+
procedure Set_Analyzed_Formal;
-- Find the node in the generic copy that corresponds to a given formal.
-- The semantic information on this node is used to perform legality
-- anonymous types, the presence a formal equality will introduce an
-- implicit declaration for the corresponding inequality.
+ ----------------------------------------
+ -- Check_Overloaded_Formal_Subprogram --
+ ----------------------------------------
+
+ procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is
+ Temp_Formal : Entity_Id;
+
+ begin
+ Temp_Formal := First (Formals);
+ while Present (Temp_Formal) loop
+ if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration
+ and then Temp_Formal /= Formal
+ and then
+ Chars (Defining_Unit_Name (Specification (Formal))) =
+ Chars (Defining_Unit_Name (Specification (Temp_Formal)))
+ then
+ if Present (Found_Assoc) then
+ Error_Msg_N
+ ("named association not allowed for overloaded formal",
+ Found_Assoc);
+
+ else
+ Error_Msg_N
+ ("named association not allowed for overloaded formal",
+ Others_Choice);
+ end if;
+
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
+
+ Next (Temp_Formal);
+ end loop;
+ end Check_Overloaded_Formal_Subprogram;
+
+ -------------------------------
+ -- Has_Fully_Defined_Profile --
+ -------------------------------
+
+ function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is
+ function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean;
+ -- Determine whethet type Typ is fully defined
+
+ ---------------------------
+ -- Is_Fully_Defined_Type --
+ ---------------------------
+
+ function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is
+ begin
+ -- A private type without a full view is not fully defined
+
+ if Is_Private_Type (Typ)
+ and then No (Full_View (Typ))
+ then
+ return False;
+
+ -- An incomplete type is never fully defined
+
+ elsif Is_Incomplete_Type (Typ) then
+ return False;
+
+ -- All other types are fully defined
+
+ else
+ return True;
+ end if;
+ end Is_Fully_Defined_Type;
+
+ -- Local declarations
+
+ Param : Entity_Id;
+
+ -- Start of processing for Has_Fully_Defined_Profile
+
+ begin
+ -- Check the parameters
+
+ Param := First_Formal (Subp);
+ while Present (Param) loop
+ if not Is_Fully_Defined_Type (Etype (Param)) then
+ return False;
+ end if;
+
+ Next_Formal (Param);
+ end loop;
+
+ -- Check the return type
+
+ return Is_Fully_Defined_Type (Etype (Subp));
+ end Has_Fully_Defined_Profile;
+
---------------------
-- Matching_Actual --
---------------------
end if;
end Process_Default;
+ ---------------------------------
+ -- Renames_Standard_Subprogram --
+ ---------------------------------
+
+ function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is
+ Id : Entity_Id;
+
+ begin
+ Id := Alias (Subp);
+ while Present (Id) loop
+ if Scope (Id) = Standard_Standard then
+ return True;
+ end if;
+
+ Id := Alias (Id);
+ end loop;
+
+ return False;
+ end Renames_Standard_Subprogram;
+
-------------------------
-- Set_Analyzed_Formal --
-------------------------
while Present (Actual) loop
if Nkind (Actual) = N_Others_Choice then
Others_Present := True;
+ Others_Choice := Actual;
if Present (Next (Actual)) then
Error_Msg_N ("others must be last association", Actual);
Named := First_Named;
while Present (Named) loop
if Nkind (Named) /= N_Others_Choice
- and then No (Selector_Name (Named))
+ and then No (Selector_Name (Named))
then
Error_Msg_N ("invalid positional actual after named one", Named);
Abandon_Instantiation (Named);
while Present (Formal) loop
Set_Analyzed_Formal;
- Next_Formal := Next_Non_Pragma (Formal);
+ Saved_Formal := Next_Non_Pragma (Formal);
case Nkind (Formal) is
when N_Formal_Object_Declaration =>
Analyze (Match);
Append_List
(Instantiate_Type
- (Formal, Match, Analyzed_Formal, Assoc),
- Assoc);
+ (Formal, Match, Analyzed_Formal, Assoc),
+ Assoc);
-- An instantiation is a freeze point for the actuals,
- -- unless this is a rewritten formal package.
+ -- unless this is a rewritten formal package, or the
+ -- formal is an Ada 2012 formal incomplete type.
+
+ if Nkind (I_Node) = N_Formal_Package_Declaration
+ or else
+ (Ada_Version >= Ada_2012
+ and then
+ Ekind (Defining_Identifier (Analyzed_Formal)) =
+ E_Incomplete_Type)
+ then
+ null;
- if Nkind (I_Node) /= N_Formal_Package_Declaration then
- Append_Elmt (Entity (Match), Actual_Types);
+ else
+ Append_Elmt (Entity (Match), Actuals_To_Freeze);
end if;
end if;
- -- A remote access-to-class-wide type must not be an
- -- actual parameter for a generic formal of an access
- -- type (E.2.2 (17)).
+ -- A remote access-to-class-wide type is not a legal actual
+ -- for a generic formal of an access type (E.2.2(17)).
if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
and then
when N_Formal_Subprogram_Declaration =>
Match :=
- Matching_Actual (
- Defining_Unit_Name (Specification (Formal)),
- Defining_Unit_Name (Specification (Analyzed_Formal)));
+ Matching_Actual
+ (Defining_Unit_Name (Specification (Formal)),
+ Defining_Unit_Name (Specification (Analyzed_Formal)));
-- If the formal subprogram has the same name as another
-- formal subprogram of the generic, then a named
and then Is_Named_Assoc
and then Comes_From_Source (Found_Assoc)
then
- Temp_Formal := First (Formals);
- while Present (Temp_Formal) loop
- if Nkind (Temp_Formal) in
- N_Formal_Subprogram_Declaration
- and then Temp_Formal /= Formal
- and then
- Chars (Selector_Name (Found_Assoc)) =
- Chars (Defining_Unit_Name
- (Specification (Temp_Formal)))
- then
- Error_Msg_N
- ("name not allowed for overloaded formal",
- Found_Assoc);
- Abandon_Instantiation (Instantiation_Node);
- end if;
-
- Next (Temp_Formal);
- end loop;
+ Check_Overloaded_Formal_Subprogram (Formal);
end if;
-- If there is no corresponding actual, this may be case of
-- partial parametrization, or else the formal has a default
-- or a box.
- if No (Match)
- and then Partial_Parametrization
- then
+ if No (Match) and then Partial_Parametrization then
Process_Default (Formal);
+
+ if Nkind (I_Node) = N_Formal_Package_Declaration then
+ Check_Overloaded_Formal_Subprogram (Formal);
+ end if;
+
else
Append_To (Assoc,
Instantiate_Formal_Subprogram
(Formal, Match, Analyzed_Formal));
+
+ -- An instantiation is a freeze point for the actuals,
+ -- unless this is a rewritten formal package.
+
+ if Nkind (I_Node) /= N_Formal_Package_Declaration
+ and then Nkind (Match) = N_Identifier
+ and then Is_Subprogram (Entity (Match))
+
+ -- The actual subprogram may rename a routine defined
+ -- in Standard. Avoid freezing such renamings because
+ -- subprograms coming from Standard cannot be frozen.
+
+ and then
+ not Renames_Standard_Subprogram (Entity (Match))
+
+ -- If the actual subprogram comes from a different
+ -- unit, it is already frozen, either by a body in
+ -- that unit or by the end of the declarative part
+ -- of the unit. This check avoids the freezing of
+ -- subprograms defined in Standard which are used
+ -- as generic actuals.
+
+ and then In_Same_Code_Unit (Entity (Match), I_Node)
+ and then Has_Fully_Defined_Profile (Entity (Match))
+ then
+ -- Mark the subprogram as having a delayed freeze
+ -- since this may be an out-of-order action.
+
+ Set_Has_Delayed_Freeze (Entity (Match));
+ Append_Elmt (Entity (Match), Actuals_To_Freeze);
+ end if;
end if;
-- If this is a nested generic, preserve default for later
end case;
- Formal := Next_Formal;
+ Formal := Saved_Formal;
Next_Non_Pragma (Analyzed_Formal);
end loop;
("too many actuals in generic instantiation", Instantiation_Node);
end if;
+ -- An instantiation freezes all generic actuals. The only exceptions
+ -- to this are incomplete types and subprograms which are not fully
+ -- defined at the point of instantiation.
+
declare
- Elmt : Elmt_Id := First_Elmt (Actual_Types);
+ Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze);
begin
while Present (Elmt) loop
Freeze_Before (I_Node, Node (Elmt));
-- static. For all scalar types we introduce an anonymous base type, with
-- the same attributes. We choose the corresponding integer type to be
-- Standard_Integer.
+ -- Here and in other similar routines, the Sloc of the generated internal
+ -- type must be the same as the sloc of the defining identifier of the
+ -- formal type declaration, to provide proper source navigation.
procedure Analyze_Formal_Decimal_Fixed_Point_Type
(T : Entity_Id;
Def : Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Def);
- Base : constant Entity_Id :=
- New_Internal_Entity
- (E_Decimal_Fixed_Point_Type,
- Current_Scope, Sloc (Def), 'G');
+ Loc : constant Source_Ptr := Sloc (Def);
+
+ Base : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Decimal_Fixed_Point_Type,
+ Current_Scope,
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
+
Int_Base : constant Entity_Id := Standard_Integer;
Delta_Val : constant Ureal := Ureal_1;
Digs_Val : constant Uint := Uint_6;
Base : constant Entity_Id :=
New_Internal_Entity
- (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
+ (E_Floating_Point_Type, Current_Scope,
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
+
begin
Enter_Name (T);
Set_Ekind (T, E_Enumeration_Subtype);
procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
Base : constant Entity_Id :=
New_Internal_Entity
- (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
+ (E_Floating_Point_Type, Current_Scope,
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
begin
-- The various semantic attributes are taken from the predefined type
Loc : constant Source_Ptr := Sloc (Def);
Base : constant Entity_Id :=
New_Internal_Entity
- (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G');
+ (E_Ordinary_Fixed_Point_Type, Current_Scope,
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
+
begin
-- The semantic attributes are set for completeness only, their values
-- will never be used, since all properties of the type are non-static.
Renaming : Node_Id;
Parent_Instance : Entity_Id;
Renaming_In_Par : Entity_Id;
- No_Associations : Boolean := False;
+ Associations : Boolean := True;
+
+ Vis_Prims_List : Elist_Id := No_Elist;
+ -- List of primitives made temporarily visible in the instantiation
+ -- to match the visibility of the formal type
function Build_Local_Package return Node_Id;
-- The formal package is rewritten so that its parameters are replaced
Decls :=
Analyze_Associations
- (Original_Node (N),
- Generic_Formal_Declarations (Act_Tree),
- Generic_Formal_Declarations (Gen_Decl));
+ (I_Node => Original_Node (N),
+ Formals => Generic_Formal_Declarations (Act_Tree),
+ F_Copy => Generic_Formal_Declarations (Gen_Decl));
+
+ Vis_Prims_List := Check_Hidden_Primitives (Decls);
end;
end if;
return Pack_Decl;
end Build_Local_Package;
- -- Start of processing for Analyze_Formal_Package
+ -- Start of processing for Analyze_Formal_Package_Declaration
begin
Text_IO_Kludge (Gen_Id);
end if;
end if;
+ -- Check that name of formal package does not hide name of generic,
+ -- or its leading prefix. This check must be done separately because
+ -- the name of the generic has already been analyzed.
+
+ declare
+ Gen_Name : Entity_Id;
+
+ begin
+ Gen_Name := Gen_Id;
+ while Nkind (Gen_Name) = N_Expanded_Name loop
+ Gen_Name := Prefix (Gen_Name);
+ end loop;
+
+ if Chars (Gen_Name) = Chars (Pack_Id) then
+ Error_Msg_NE
+ ("& is hidden within declaration of formal package",
+ Gen_Id, Gen_Name);
+ end if;
+ end;
+
if Box_Present (N)
or else No (Generic_Associations (N))
or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
then
- No_Associations := True;
+ Associations := False;
end if;
-- If there are no generic associations, the generic parameters appear
Enter_Name (Formal);
Set_Ekind (Formal, E_Variable);
Set_Etype (Formal, Any_Type);
+ Restore_Hidden_Primitives (Vis_Prims_List);
if Parent_Installed then
Remove_Parent;
-- outside of the formal package. The others are still declared by a
-- formal parameter declaration.
- if not No_Associations then
- declare
- E : Entity_Id;
+ -- If there are no associations, the only local entity to hide is the
+ -- generated package renaming itself.
- begin
- E := First_Entity (Formal);
- while Present (E) loop
- exit when Ekind (E) = E_Package
- and then Renamed_Entity (E) = Formal;
+ declare
+ E : Entity_Id;
- if not Is_Generic_Formal (E) then
- Set_Is_Hidden (E);
- end if;
+ begin
+ E := First_Entity (Formal);
+ while Present (E) loop
+ if Associations
+ and then not Is_Generic_Formal (E)
+ then
+ Set_Is_Hidden (E);
+ end if;
- Next_Entity (E);
- end loop;
- end;
- end if;
+ if Ekind (E) = E_Package
+ and then Renamed_Entity (E) = Formal
+ then
+ Set_Is_Hidden (E);
+ exit;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end;
End_Package_Scope (Formal);
+ Restore_Hidden_Primitives (Vis_Prims_List);
if Parent_Installed then
Remove_Parent;
Set_RM_Size (T, RM_Size (Standard_Integer));
end Analyze_Formal_Private_Type;
+ ------------------------------------
+ -- Analyze_Formal_Incomplete_Type --
+ ------------------------------------
+
+ procedure Analyze_Formal_Incomplete_Type
+ (T : Entity_Id;
+ Def : Node_Id)
+ is
+ begin
+ Enter_Name (T);
+ Set_Ekind (T, E_Incomplete_Type);
+ Set_Etype (T, T);
+ Set_Private_Dependents (T, New_Elmt_List);
+
+ if Tagged_Present (Def) then
+ Set_Is_Tagged_Type (T);
+ Make_Class_Wide_Type (T);
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+ end if;
+ end Analyze_Formal_Incomplete_Type;
+
----------------------------------------
-- Analyze_Formal_Signed_Integer_Type --
----------------------------------------
is
Base : constant Entity_Id :=
New_Internal_Entity
- (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G');
+ (E_Signed_Integer_Type,
+ Current_Scope,
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
begin
Enter_Name (T);
end;
if Subp /= Any_Id then
+
+ -- Subprogram found, generate reference to it
+
Set_Entity (Def, Subp);
+ Generate_Reference (Subp, Def);
if Subp = Nam then
Error_Msg_N ("premature usage of formal subprogram", Def);
when N_Formal_Derived_Type_Definition =>
Analyze_Formal_Derived_Type (N, T, Def);
+ when N_Formal_Incomplete_Type_Definition =>
+ Analyze_Formal_Incomplete_Type (T, Def);
+
when N_Formal_Discrete_Type_Definition =>
Analyze_Formal_Discrete_Type (T, Def);
Decl : Node_Id;
begin
+ Check_SPARK_Restriction ("generic is not allowed", N);
+
-- We introduce a renaming of the enclosing package, to have a usable
-- entity as the prefix of an expanded name for a local entity of the
-- form Par.P.Q, where P is the generic package. This is because a local
Typ : Entity_Id;
begin
+ Check_SPARK_Restriction ("generic is not allowed", N);
+
-- Create copy of generic unit, and save for instantiation. If the unit
-- is a child unit, do not copy the specifications for the parent, which
-- are not part of the generic tree.
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);
+ Set_Contract (Id, Make_Contract (Sloc (Id)));
if Nkind (Id) = N_Defining_Operator_Symbol then
Error_Msg_N
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);
-
- if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Id);
- end if;
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
return False;
end Might_Inline_Subp;
+ -- Local declarations
+
+ Vis_Prims_List : Elist_Id := No_Elist;
+ -- List of primitives made temporarily visible in the instantiation
+ -- to match the visibility of the formal type
+
-- Start of processing for Analyze_Package_Instantiation
begin
+ Check_SPARK_Restriction ("generic is not allowed", N);
+
-- Very first thing: apply the special kludge for Text_IO processing
-- in case we are instantiating one of the children of [Wide_]Text_IO.
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
Renaming_List :=
Analyze_Associations
- (N,
- Generic_Formal_Declarations (Act_Tree),
- Generic_Formal_Declarations (Gen_Decl));
+ (I_Node => N,
+ Formals => Generic_Formal_Declarations (Act_Tree),
+ F_Copy => Generic_Formal_Declarations (Gen_Decl));
+
+ Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
Set_Instance_Env (Gen_Unit, Act_Decl_Id);
Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
or else Might_Inline_Subp)
and then not Is_Actual_Pack
and then not Inline_Now
+ and then not Alfa_Mode
and then (Operating_Mode = Generate_Code
- or else (Operating_Mode = Check_Semantics
- and then ASIS_Mode));
+ or else (Operating_Mode = Check_Semantics
+ and then ASIS_Mode));
-- If front_end_inlining is enabled, do not instantiate body if
-- within a generic context.
if (Front_End_Inlining
- and then not Expander_Active)
+ and then not Expander_Active)
or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
then
Needs_Body := False;
begin
if Nkind (Decl) = N_Formal_Package_Declaration
or else (Nkind (Decl) = N_Package_Declaration
- and then Is_List_Member (Decl)
- and then Present (Next (Decl))
- and then
- Nkind (Next (Decl)) =
+ and then Is_List_Member (Decl)
+ and then Present (Next (Decl))
+ and then
+ Nkind (Next (Decl)) =
N_Formal_Package_Declaration)
then
Needs_Body := False;
end if;
end;
- -- If we are generating calling stubs, we never need a body for an
- -- instantiation from source. However normal processing occurs for
- -- any generic instantiation appearing in generated code, since we
- -- do not generate stubs in that case.
+ -- Note that we generate the instance body even when generating
+ -- calling stubs for an RCI unit: it may be required e.g. if it
+ -- provides stream attributes for some type used in the profile of a
+ -- remote subprogram. If the instantiation is within the visible part
+ -- of the RCI, then calling stubs for any relevant subprogram will
+ -- be inserted immediately after the subprogram declaration, and
+ -- will take precedence over the subsequent (original) body. (The
+ -- stub and original body will be complete homographs, but this is
+ -- permitted in an instance).
- if Distribution_Stub_Mode = Generate_Caller_Stub_Body
- and then Comes_From_Source (N)
- then
- Needs_Body := False;
- end if;
+ -- Could we do better and remove the original subprogram body in that
+ -- case???
if Needs_Body then
Enclosing_Master := Scope (Enclosing_Master);
end if;
- elsif Ekind (Enclosing_Master) = E_Generic_Package then
- Enclosing_Master := Scope (Enclosing_Master);
-
- elsif Is_Generic_Subprogram (Enclosing_Master)
+ elsif Is_Generic_Unit (Enclosing_Master)
or else Ekind (Enclosing_Master) = E_Void
then
-- Cleanup actions will eventually be performed on the
- -- enclosing instance, if any. Enclosing scope is void
- -- in the formal part of a generic subprogram.
+ -- enclosing subprogram or package instance, if any.
+ -- Enclosing scope is void in the formal part of a
+ -- generic subprogram.
exit Scope_Loop;
Check_Formal_Packages (Act_Decl_Id);
+ Restore_Hidden_Primitives (Vis_Prims_List);
Restore_Private_Views (Act_Decl_Id);
Inherit_Context (Gen_Decl, N);
Set_Defining_Identifier (N, Act_Decl_Id);
end if;
+ Style_Check := Save_Style_Check;
+
+ -- Check that if N is an instantiation of System.Dim_Float_IO or
+ -- System.Dim_Integer_IO, the formal type has a dimension system.
+
+ if Nkind (N) = N_Package_Instantiation
+ and then Is_Dim_IO_Package_Instantiation (N)
+ then
+ declare
+ Assoc : constant Node_Id := First (Generic_Associations (N));
+ begin
+ if not Has_Dimension_System
+ (Etype (Explicit_Generic_Actual_Parameter (Assoc)))
+ then
+ Error_Msg_N ("type with a dimension system expected", Assoc);
+ end if;
+ end;
+ end if;
+
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Act_Decl_Id);
if Env_Installed then
Restore_Env;
end if;
+
+ Style_Check := Save_Style_Check;
end Analyze_Package_Instantiation;
--------------------------
is
begin
if (Is_In_Main_Unit (N)
- or else Is_Inlined (Subp)
- or else Is_Inlined (Alias (Subp)))
+ or else Is_Inlined (Subp)
+ or else Is_Inlined (Alias (Subp)))
and then (Operating_Mode = Generate_Code
- or else (Operating_Mode = Check_Semantics
- and then ASIS_Mode))
- and then (Expander_Active or else ASIS_Mode)
+ or else (Operating_Mode = Check_Semantics
+ and then ASIS_Mode))
+ and then (Full_Expander_Active or else ASIS_Mode)
and then not ABE_Is_Certain (N)
and then not Is_Eliminated (Subp)
then
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version));
return True;
+
else
return False;
end if;
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
end if;
end Analyze_Instance_And_Renamings;
+ -- Local variables
+
+ Vis_Prims_List : Elist_Id := No_Elist;
+ -- List of primitives made temporarily visible in the instantiation
+ -- to match the visibility of the formal type
+
-- Start of processing for Analyze_Subprogram_Instantiation
begin
+ Check_SPARK_Restriction ("generic is not allowed", N);
+
-- Very first thing: apply the special kludge for Text_IO processing
-- in case we are instantiating one of the children of [Wide_]Text_IO.
-- Of course such an instantiation is bogus (these are packages, not
-- 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;
Error_Msg_NE
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
+ Restore_Hidden_Primitives (Vis_Prims_List);
goto Leave;
end if;
Renaming_List :=
Analyze_Associations
- (N,
- Generic_Formal_Declarations (Act_Tree),
- Generic_Formal_Declarations (Gen_Decl));
+ (I_Node => N,
+ Formals => Generic_Formal_Declarations (Act_Tree),
+ F_Copy => Generic_Formal_Declarations (Gen_Decl));
+
+ Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
-- The subprogram itself cannot contain a nested instance, so the
-- current parent is left empty.
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
-- for the compilation, we generate the instance body even if it is
-- not within the main unit.
- -- Any other pragmas might also be inherited ???
-
if Is_Intrinsic_Subprogram (Gen_Unit) then
Set_Is_Intrinsic_Subprogram (Anon_Id);
Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
end if;
end if;
+ -- Inherit convention from generic unit. Intrinsic convention, as for
+ -- an instance of unchecked conversion, is not inherited because an
+ -- explicit Ada instance has been created.
+
+ if Has_Convention_Pragma (Gen_Unit)
+ and then Convention (Gen_Unit) /= Convention_Intrinsic
+ then
+ Set_Convention (Act_Decl_Id, Convention (Gen_Unit));
+ Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit));
+ end if;
+
Generate_Definition (Act_Decl_Id);
+ Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id))); -- ??? needed?
+ Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id)));
+
+ -- Inherit all inlining-related flags which apply to the generic in
+ -- the subprogram and its declaration.
Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
+ Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit));
+ Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit));
+
+ Set_Has_Pragma_Inline_Always
+ (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit));
+ Set_Has_Pragma_Inline_Always
+ (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit));
+
if not Is_Intrinsic_Subprogram (Gen_Unit) then
Check_Elab_Instantiation (N);
end if;
Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
- -- Subject to change, pending on if other pragmas are inherited ???
-
Validate_Categorization_Dependency (N, Act_Decl_Id);
if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
Remove_Parent;
end if;
+ Restore_Hidden_Primitives (Vis_Prims_List);
Restore_Env;
Env_Installed := False;
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
end if;
+ Style_Check := Save_Style_Check;
+
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Act_Decl_Id);
if Env_Installed then
Restore_Env;
end if;
+
+ Style_Check := Save_Style_Check;
end Analyze_Subprogram_Instantiation;
-------------------------
then
null;
+ -- If the formal package has an "others" box association that
+ -- covers this formal, there is no need for a check either.
+
+ elsif Nkind (Unit_Declaration_Node (E2)) in
+ N_Formal_Subprogram_Declaration
+ and then Box_Present (Unit_Declaration_Node (E2))
+ then
+ null;
+
+ -- No check needed if subprogram is a defaulted null procedure
+
+ elsif No (Alias (E2))
+ and then Ekind (E2) = E_Procedure
+ and then
+ Null_Present (Specification (Unit_Declaration_Node (E2)))
+ then
+ null;
+
+ -- Otherwise the actual in the formal and the actual in the
+ -- instantiation of the formal must match, up to renamings.
+
else
Check_Mismatch
(Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
end if;
end Check_Private_View;
- --------------------------
- -- Contains_Instance_Of --
- --------------------------
+ -----------------------------
+ -- Check_Hidden_Primitives --
+ -----------------------------
- function Contains_Instance_Of
- (Inner : Entity_Id;
- Outer : Entity_Id;
- N : Node_Id) return Boolean
- is
- Elmt : Elmt_Id;
- Scop : Entity_Id;
+ function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is
+ Actual : Node_Id;
+ Gen_T : Entity_Id;
+ Result : Elist_Id := No_Elist;
begin
- Scop := Outer;
+ if No (Assoc_List) then
+ return No_Elist;
+ end if;
+
+ -- Traverse the list of associations between formals and actuals
+ -- searching for renamings of tagged types
+
+ Actual := First (Assoc_List);
+ while Present (Actual) loop
+ if Nkind (Actual) = N_Subtype_Declaration then
+ Gen_T := Generic_Parent_Type (Actual);
+
+ if Present (Gen_T)
+ and then Is_Tagged_Type (Gen_T)
+ then
+ -- Traverse the list of primitives of the actual types
+ -- searching for hidden primitives that are visible in the
+ -- corresponding generic formal; leave them visible and
+ -- append them to Result to restore their decoration later.
+
+ Install_Hidden_Primitives
+ (Prims_List => Result,
+ Gen_T => Gen_T,
+ Act_T => Entity (Subtype_Indication (Actual)));
+ end if;
+ end if;
+
+ Next (Actual);
+ end loop;
+
+ return Result;
+ end Check_Hidden_Primitives;
+
+ --------------------------
+ -- Contains_Instance_Of --
+ --------------------------
+
+ function Contains_Instance_Of
+ (Inner : Entity_Id;
+ Outer : Entity_Id;
+ N : Node_Id) return Boolean
+ is
+ Elmt : Elmt_Id;
+ Scop : Entity_Id;
+
+ begin
+ Scop := Outer;
-- Verify that there are no circular instantiations. We check whether
-- the unit contains an instance of the current scope or some enclosing
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;
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
Expander_Mode_Restore;
end End_Generic;
+ -------------
+ -- Earlier --
+ -------------
+
+ function Earlier (N1, N2 : Node_Id) return Boolean is
+ procedure Find_Depth (P : in out Node_Id; D : in out Integer);
+ -- Find distance from given node to enclosing compilation unit
+
+ ----------------
+ -- Find_Depth --
+ ----------------
+
+ procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
+ begin
+ while Present (P)
+ and then Nkind (P) /= N_Compilation_Unit
+ loop
+ P := True_Parent (P);
+ D := D + 1;
+ end loop;
+ end Find_Depth;
+
+ -- Local declarations
+
+ D1 : Integer := 0;
+ D2 : Integer := 0;
+ P1 : Node_Id := N1;
+ P2 : Node_Id := N2;
+
+ -- Start of processing for Earlier
+
+ begin
+ Find_Depth (P1, D1);
+ Find_Depth (P2, D2);
+
+ if P1 /= P2 then
+ return False;
+ else
+ P1 := N1;
+ P2 := N2;
+ end if;
+
+ while D1 > D2 loop
+ P1 := True_Parent (P1);
+ D1 := D1 - 1;
+ end loop;
+
+ while D2 > D1 loop
+ P2 := True_Parent (P2);
+ D2 := D2 - 1;
+ 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.
+ -- 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)
+ or else List_Containing (P1) /= List_Containing (P2)
+ loop
+ P1 := True_Parent (P1);
+ P2 := True_Parent (P2);
+
+ if Nkind (Parent (P1)) = N_Subunit then
+ P1 := Corresponding_Stub (Parent (P1));
+ end if;
+
+ if Nkind (Parent (P2)) = N_Subunit then
+ P2 := Corresponding_Stub (Parent (P2));
+ end if;
+
+ if P1 = P2 then
+ return False;
+ end if;
+ end loop;
+
+ -- Expanded code usually shares the source location of the original
+ -- construct it was generated for. This however may not necessarely
+ -- reflect the true location of the code within the tree.
+
+ -- Before comparing the slocs of the two nodes, make sure that we are
+ -- working with correct source locations. Assume that P1 is to the left
+ -- of P2. If either one does not come from source, traverse the common
+ -- list heading towards the other node and locate the first source
+ -- statement.
+
+ -- P1 P2
+ -- ----+===+===+--------------+===+===+----
+ -- expanded code expanded code
+
+ if not Comes_From_Source (P1) then
+ while Present (P1) loop
+
+ -- Neither P2 nor a source statement were located during the
+ -- search. If we reach the end of the list, then P1 does not
+ -- occur earlier than P2.
+
+ -- ---->
+ -- start --- P2 ----- P1 --- end
+
+ if No (Next (P1)) then
+ return False;
+
+ -- We encounter P2 while going to the right of the list. This
+ -- means that P1 does indeed appear earlier.
+
+ -- ---->
+ -- start --- P1 ===== P2 --- end
+ -- expanded code in between
+
+ elsif P1 = P2 then
+ return True;
+
+ -- No need to look any further since we have located a source
+ -- statement.
+
+ elsif Comes_From_Source (P1) then
+ exit;
+ end if;
+
+ -- Keep going right
+
+ Next (P1);
+ end loop;
+ end if;
+
+ if not Comes_From_Source (P2) then
+ while Present (P2) loop
+
+ -- Neither P1 nor a source statement were located during the
+ -- search. If we reach the start of the list, then P1 does not
+ -- occur earlier than P2.
+
+ -- <----
+ -- start --- P2 --- P1 --- end
+
+ if No (Prev (P2)) then
+ return False;
+
+ -- We encounter P1 while going to the left of the list. This
+ -- means that P1 does indeed appear earlier.
+
+ -- <----
+ -- start --- P1 ===== P2 --- end
+ -- expanded code in between
+
+ elsif P2 = P1 then
+ return True;
+
+ -- No need to look any further since we have located a source
+ -- statement.
+
+ elsif Comes_From_Source (P2) then
+ exit;
+ end if;
+
+ -- Keep going left
+
+ Prev (P2);
+ end loop;
+ end if;
+
+ -- At this point either both nodes came from source or we approximated
+ -- their source locations through neighbouring source statements.
+
+ if Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)) then
+ return True;
+ else
+ return False;
+ end if;
+ end Earlier;
+
----------------------
-- Find_Actual_Type --
----------------------
Gen_Body : Node_Id;
Pack_Id : Entity_Id)
is
- F_Node : Node_Id;
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Par : constant Entity_Id := Scope (Gen_Unit);
+ E_G_Id : Entity_Id;
Enc_G : Entity_Id;
Enc_I : Node_Id;
- E_G_Id : Entity_Id;
-
- function Earlier (N1, N2 : Node_Id) return Boolean;
- -- Yields True if N1 and N2 appear in the same compilation unit,
- -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
- -- traversal of the tree for the unit.
+ F_Node : Node_Id;
- function Enclosing_Body (N : Node_Id) return Node_Id;
+ function Enclosing_Package_Body (N : Node_Id) return Node_Id;
-- Find innermost package body that encloses the given node, and which
-- is not a compilation unit. Freeze nodes for the instance, or for its
-- enclosing body, may be inserted after the enclosing_body of the
- -- generic unit.
+ -- generic unit. Used to determine proper placement of freeze node for
+ -- both package and subprogram instances.
function Package_Freeze_Node (B : Node_Id) return Node_Id;
-- Find entity for given package body, and locate or create a freeze
-- node for it.
- function True_Parent (N : Node_Id) return Node_Id;
- -- For a subunit, return parent of corresponding stub
-
- -------------
- -- Earlier --
- -------------
-
- function Earlier (N1, N2 : Node_Id) return Boolean is
- D1 : Integer := 0;
- D2 : Integer := 0;
- P1 : Node_Id := N1;
- 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_Depth --
- ----------------
-
- procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
- begin
- while Present (P)
- and then Nkind (P) /= N_Compilation_Unit
- loop
- P := True_Parent (P);
- D := D + 1;
- end loop;
- end Find_Depth;
-
- -- Start of processing for Earlier
-
- begin
- Find_Depth (P1, D1);
- Find_Depth (P2, D2);
-
- if P1 /= P2 then
- return False;
- else
- P1 := N1;
- P2 := N2;
- end if;
-
- while D1 > D2 loop
- P1 := True_Parent (P1);
- D1 := D1 - 1;
- end loop;
-
- while D2 > D1 loop
- P2 := True_Parent (P2);
- D2 := D2 - 1;
- 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.
-
- while not Is_List_Member (P1)
- or else not Is_List_Member (P2)
- or else List_Containing (P1) /= List_Containing (P2)
- loop
- P1 := True_Parent (P1);
- P2 := True_Parent (P2);
-
- if Nkind (Parent (P1)) = N_Subunit then
- P1 := Corresponding_Stub (Parent (P1));
- end if;
-
- if Nkind (Parent (P2)) = N_Subunit then
- P2 := Corresponding_Stub (Parent (P2));
- end if;
-
- if P1 = P2 then
- return False;
- end if;
- end loop;
-
- return
- Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
- end Earlier;
-
- --------------------
- -- Enclosing_Body --
- --------------------
+ ----------------------------
+ -- Enclosing_Package_Body --
+ ----------------------------
- function Enclosing_Body (N : Node_Id) return Node_Id is
- P : Node_Id := Parent (N);
+ function Enclosing_Package_Body (N : Node_Id) return Node_Id is
+ P : Node_Id;
begin
+ P := Parent (N);
while Present (P)
and then Nkind (Parent (P)) /= N_Compilation_Unit
loop
if Nkind (P) = N_Package_Body then
-
if Nkind (Parent (P)) = N_Subunit then
return Corresponding_Stub (Parent (P));
else
end loop;
return Empty;
- end Enclosing_Body;
+ end Enclosing_Package_Body;
-------------------------
-- Package_Freeze_Node --
begin
if Nkind (B) = N_Package_Body then
Id := Corresponding_Spec (B);
-
else pragma Assert (Nkind (B) = N_Package_Body_Stub);
Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
end if;
return Freeze_Node (Id);
end Package_Freeze_Node;
- -----------------
- -- True_Parent --
- -----------------
-
- function True_Parent (N : Node_Id) return Node_Id is
- begin
- if Nkind (Parent (N)) = N_Subunit then
- return Parent (Corresponding_Stub (Parent (N)));
- else
- return Parent (N);
- end if;
- end True_Parent;
-
-- Start of processing of Freeze_Subprogram_Body
begin
-- packages. Otherwise, the freeze node is placed at the end of the
-- current declarative part.
- Enc_G := Enclosing_Body (Gen_Body);
- Enc_I := Enclosing_Body (Inst_Node);
+ Enc_G := Enclosing_Package_Body (Gen_Body);
+ Enc_I := Enclosing_Package_Body (Inst_Node);
Ensure_Freeze_Node (Pack_Id);
F_Node := Freeze_Node (Pack_Id);
if Is_Generic_Instance (Par)
and then Present (Freeze_Node (Par))
- and then
- In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
+ and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
then
- if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
-
- -- The parent was a premature instantiation. Insert freeze node at
- -- the end the current declarative part.
+ -- The parent was a premature instantiation. Insert freeze node at
+ -- the end the current declarative part.
- Insert_After_Last_Decl (Inst_Node, F_Node);
+ if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
+ Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
+
+ -- Handle the following case:
+ --
+ -- package Parent_Inst is new ...
+ -- Parent_Inst []
+ --
+ -- procedure P ... -- this body freezes Parent_Inst
+ --
+ -- package Inst is new ...
+ --
+ -- In this particular scenario, the freeze node for Inst must be
+ -- inserted in the same manner as that of Parent_Inst - before the
+ -- next source body or at the end of the declarative list (body not
+ -- available). If body P did not exist and Parent_Inst was frozen
+ -- after Inst, either by a body following Inst or at the end of the
+ -- declarative region, the freeze node for Inst must be inserted
+ -- after that of Parent_Inst. This relation is established by
+ -- comparing the Slocs of Parent_Inst freeze node and Inst.
+
+ elsif List_Containing (Get_Package_Instantiation_Node (Par)) =
+ List_Containing (Inst_Node)
+ and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node)
+ then
+ Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
else
Insert_After (Freeze_Node (Par), F_Node);
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
+ Insert_Freeze_Node_For_Instance
(Freeze_Node (Par), Package_Freeze_Node (Enc_I));
end if;
- Insert_After_Last_Decl (Inst_Node, F_Node);
+ Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
elsif Present (Enc_G)
and then Present (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;
end if;
if Parent (List_Containing (Enc_G)) /= Enclosing_Body then
- Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I));
+ Insert_Freeze_Node_For_Instance
+ (Enc_G, Package_Freeze_Node (Enc_I));
end if;
end;
Insert_After (Enc_G, Freeze_Node (E_G_Id));
end if;
- Insert_After_Last_Decl (Inst_Node, F_Node);
+ Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
else
-- If none of the above, insert freeze node at the end of the current
-- declarative part.
- Insert_After_Last_Decl (Inst_Node, F_Node);
+ Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
end if;
end Freeze_Subprogram_Body;
-- 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;
elsif Nkind_In (Nod, N_Subprogram_Body,
N_Package_Body,
+ N_Package_Declaration,
N_Task_Body,
N_Protected_Body,
N_Block_Statement)
return False;
elsif Nkind (Nod) = N_Subunit then
- Nod := Corresponding_Stub (Nod);
+ Nod := Corresponding_Stub (Nod);
elsif Nkind (Nod) = N_Compilation_Unit then
return False;
-- 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;
Hidden_Entities := No_Elist;
end Initialize;
- ----------------------------
- -- Insert_After_Last_Decl --
- ----------------------------
+ -------------------------------------
+ -- Insert_Freeze_Node_For_Instance --
+ -------------------------------------
+
+ procedure Insert_Freeze_Node_For_Instance
+ (N : Node_Id;
+ F_Node : Node_Id)
+ is
+ Inst : constant Entity_Id := Entity (F_Node);
+ Decl : Node_Id;
+ Decls : List_Id;
+ Par_N : Node_Id;
+
+ function Enclosing_Body (N : Node_Id) return Node_Id;
+ -- Find enclosing package or subprogram body, if any. Freeze node
+ -- may be placed at end of current declarative list if previous
+ -- instance and current one have different enclosing bodies.
+
+ function Previous_Instance (Gen : Entity_Id) return Entity_Id;
+ -- Find the local instance, if any, that declares the generic that is
+ -- being instantiated. If present, the freeze node for this instance
+ -- must follow the freeze node for the previous instance.
+
+ --------------------
+ -- Enclosing_Body --
+ --------------------
+
+ function Enclosing_Body (N : Node_Id) return Node_Id is
+ P : Node_Id;
+
+ begin
+ P := Parent (N);
+ while Present (P)
+ and then Nkind (Parent (P)) /= N_Compilation_Unit
+ loop
+ if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
+ if Nkind (Parent (P)) = N_Subunit then
+ return Corresponding_Stub (Parent (P));
+ else
+ return P;
+ end if;
+ end if;
+
+ P := True_Parent (P);
+ end loop;
+
+ return Empty;
+ end Enclosing_Body;
+
+ -----------------------
+ -- Previous_Instance --
+ -----------------------
- procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
- L : List_Id := List_Containing (N);
- P : constant Node_Id := Parent (L);
+ function Previous_Instance (Gen : Entity_Id) return Entity_Id is
+ S : Entity_Id;
+
+ begin
+ S := Scope (Gen);
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Generic_Instance (S)
+ and then In_Same_Source_Unit (S, N)
+ then
+ return S;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return Empty;
+ end Previous_Instance;
+
+ -- Start of processing for Insert_Freeze_Node_For_Instance
begin
if not Is_List_Member (F_Node) then
- if Nkind (P) = N_Package_Specification
- and then L = Visible_Declarations (P)
- and then Present (Private_Declarations (P))
- and then not Is_Empty_List (Private_Declarations (P))
+ Decls := List_Containing (N);
+ Par_N := Parent (Decls);
+ Decl := N;
+
+ -- If this is a package instance, check whether the generic is
+ -- declared in a previous instance and the current instance is
+ -- not within the previous one.
+
+ if Present (Generic_Parent (Parent (Inst)))
+ and then Is_In_Main_Unit (N)
+ then
+ declare
+ Enclosing_N : constant Node_Id := Enclosing_Body (N);
+ Par_I : constant Entity_Id :=
+ Previous_Instance
+ (Generic_Parent (Parent (Inst)));
+ Scop : Entity_Id;
+
+ begin
+ if Present (Par_I)
+ and then Earlier (N, Freeze_Node (Par_I))
+ then
+ Scop := Scope (Inst);
+
+ -- If the current instance is within the one that contains
+ -- the generic, the freeze node for the current one must
+ -- appear in the current declarative part. Ditto, if the
+ -- current instance is within another package instance or
+ -- within a body that does not enclose the current instance.
+ -- In these three cases the freeze node of the previous
+ -- instance is not relevant.
+
+ while Present (Scop)
+ and then Scop /= Standard_Standard
+ loop
+ exit when Scop = Par_I
+ or else
+ (Is_Generic_Instance (Scop)
+ and then Scope_Depth (Scop) > Scope_Depth (Par_I));
+ Scop := Scope (Scop);
+ end loop;
+
+ -- Previous instance encloses current instance
+
+ if Scop = Par_I then
+ null;
+
+ -- If the next node is a source body we must freeze in
+ -- the current scope as well.
+
+ elsif Present (Next (N))
+ and then Nkind_In (Next (N),
+ N_Subprogram_Body, N_Package_Body)
+ and then Comes_From_Source (Next (N))
+ then
+ null;
+
+ -- Current instance is within an unrelated instance
+
+ elsif Is_Generic_Instance (Scop) then
+ null;
+
+ -- Current instance is within an unrelated body
+
+ elsif Present (Enclosing_N)
+ and then Enclosing_N /= Enclosing_Body (Par_I)
+ then
+ null;
+
+ else
+ Insert_After (Freeze_Node (Par_I), F_Node);
+ return;
+ end if;
+ end if;
+ end;
+ end if;
+
+ -- When the instantiation occurs in a package declaration, append the
+ -- freeze node to the private declarations (if any).
+
+ if Nkind (Par_N) = N_Package_Specification
+ and then Decls = Visible_Declarations (Par_N)
+ and then Present (Private_Declarations (Par_N))
+ and then not Is_Empty_List (Private_Declarations (Par_N))
+ then
+ Decls := Private_Declarations (Par_N);
+ Decl := First (Decls);
+ end if;
+
+ -- Determine the proper freeze point of a package instantiation. We
+ -- adhere to the general rule of a package or subprogram body causing
+ -- freezing of anything before it in the same declarative region. In
+ -- this case, the proper freeze point of a package instantiation is
+ -- before the first source body which follows, or before a stub. This
+ -- ensures that entities coming from the instance are already frozen
+ -- and usable in source bodies.
+
+ if Nkind (Par_N) /= N_Package_Declaration
+ and then Ekind (Inst) = E_Package
+ and then Is_Generic_Instance (Inst)
+ and then
+ not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst)
then
- L := Private_Declarations (P);
+ while Present (Decl) loop
+ if (Nkind (Decl) in N_Unit_Body
+ or else
+ Nkind (Decl) in N_Body_Stub)
+ and then Comes_From_Source (Decl)
+ then
+ Insert_Before (Decl, F_Node);
+ return;
+ end if;
+
+ Next (Decl);
+ end loop;
end if;
- Insert_After (Last (L), F_Node);
+ -- In a package declaration, or if no previous body, insert at end
+ -- of list.
+
+ Set_Sloc (F_Node, Sloc (Last (Decls)));
+ Insert_After (Last (Decls), F_Node);
end if;
- end Insert_After_Last_Decl;
+ end Insert_Freeze_Node_For_Instance;
------------------
-- Install_Body --
--------------------
function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
- Scop : Entity_Id := Scope (Id);
+ Scop : Entity_Id;
begin
+ Scop := Scope (Id);
while Scop /= Standard_Standard
and then not Is_Overloadable (Scop)
loop
-- Start of processing for Install_Body
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));
-- generic.
if In_Same_Declarative_Part (Freeze_Node (Par), N) then
- Insert_After (Freeze_Node (Par), F_Node);
+
+ -- Handle the following case:
+
+ -- package Parent_Inst is new ...
+ -- Parent_Inst []
+
+ -- procedure P ... -- this body freezes Parent_Inst
+
+ -- package Inst is new ...
+
+ -- In this particular scenario, the freeze node for Inst must
+ -- be inserted in the same manner as that of Parent_Inst -
+ -- before the next source body or at the end of the declarative
+ -- list (body not available). If body P did not exist and
+ -- Parent_Inst was frozen after Inst, either by a body
+ -- following Inst or at the end of the declarative region, the
+ -- freeze node for Inst must be inserted after that of
+ -- Parent_Inst. This relation is established by comparing the
+ -- Slocs of Parent_Inst freeze node and Inst.
+
+ if List_Containing (Get_Package_Instantiation_Node (Par)) =
+ List_Containing (N)
+ and then Sloc (Freeze_Node (Par)) < Sloc (N)
+ then
+ Insert_Freeze_Node_For_Instance (N, F_Node);
+ else
+ Insert_After (Freeze_Node (Par), F_Node);
+ end if;
-- Freeze package enclosing instance of inner generic after
-- instance of enclosing generic.
- elsif Nkind (Parent (N)) = N_Package_Body
+ elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body)
and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
then
-
declare
- Enclosing : constant Entity_Id :=
- Corresponding_Spec (Parent (N));
+ Enclosing : Entity_Id;
begin
- Insert_After_Last_Decl (N, F_Node);
+ Enclosing := Corresponding_Spec (Parent (N));
+
+ if No (Enclosing) then
+ Enclosing := Defining_Entity (Parent (N));
+ end if;
+
+ Insert_Freeze_Node_For_Instance (N, F_Node);
Ensure_Freeze_Node (Enclosing);
if not Is_List_Member (Freeze_Node (Enclosing)) then
- Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
+
+ -- The enclosing context is a subunit, insert the freeze
+ -- node after the stub.
+
+ if Nkind (Parent (Parent (N))) = N_Subunit then
+ Insert_Freeze_Node_For_Instance
+ (Corresponding_Stub (Parent (Parent (N))),
+ Freeze_Node (Enclosing));
+
+ -- The enclosing context is a package with a stub body
+ -- which has already been replaced by the real body.
+ -- Insert the freeze node after the actual body.
+
+ elsif Ekind (Enclosing) = E_Package
+ and then Present (Body_Entity (Enclosing))
+ and then Was_Originally_Stub
+ (Parent (Body_Entity (Enclosing)))
+ then
+ Insert_Freeze_Node_For_Instance
+ (Parent (Body_Entity (Enclosing)),
+ Freeze_Node (Enclosing));
+
+ -- The parent instance has been frozen before the body of
+ -- the enclosing package, insert the freeze node after
+ -- the body.
+
+ elsif List_Containing (Freeze_Node (Par)) =
+ List_Containing (Parent (N))
+ and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N))
+ then
+ Insert_Freeze_Node_For_Instance
+ (Parent (N), Freeze_Node (Enclosing));
+
+ else
+ Insert_After
+ (Freeze_Node (Par), Freeze_Node (Enclosing));
+ end if;
end if;
end;
else
- Insert_After_Last_Decl (N, F_Node);
+ Insert_Freeze_Node_For_Instance (N, F_Node);
end if;
else
- Insert_After_Last_Decl (N, F_Node);
+ Insert_Freeze_Node_For_Instance (N, F_Node);
end if;
end if;
begin
E := First_Entity (Par);
- -- In we are installing an instance parent, locate the formal packages
+ -- If we are installing an instance parent, locate the formal packages
-- of its generic parent.
if Is_Generic_Instance (Par) then
-- Finally, the parent may be a generic (not an instance) when the
-- child unit appears as a formal package.
- Inst_Par := P;
+ Inst_Par := P;
+
+ if Present (Renamed_Entity (Inst_Par)) then
+ Inst_Par := Renamed_Entity (Inst_Par);
+ end if;
+
+ First_Par := Inst_Par;
+
+ Gen_Par :=
+ Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
+
+ First_Gen := Gen_Par;
+
+ while Present (Gen_Par)
+ and then Is_Child_Unit (Gen_Par)
+ loop
+ -- Load grandparent instance as well
+
+ Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
+
+ if Nkind (Name (Inst_Node)) = N_Expanded_Name then
+ Inst_Par := Entity (Prefix (Name (Inst_Node)));
+
+ if Present (Renamed_Entity (Inst_Par)) then
+ Inst_Par := Renamed_Entity (Inst_Par);
+ end if;
+
+ Gen_Par :=
+ Generic_Parent
+ (Specification (Unit_Declaration_Node (Inst_Par)));
+
+ if Present (Gen_Par) then
+ Prepend_Elmt (Inst_Par, Ancestors);
+
+ else
+ -- Parent is not the name of an instantiation
+
+ Install_Noninstance_Specs (Inst_Par);
+ exit;
+ end if;
+
+ else
+ -- Previous error
+
+ exit;
+ end if;
+ end loop;
+
+ if Present (First_Gen) then
+ Append_Elmt (First_Par, Ancestors);
+ else
+ Install_Noninstance_Specs (First_Par);
+ end if;
+
+ if not Is_Empty_Elmt_List (Ancestors) then
+ Elmt := First_Elmt (Ancestors);
+ while Present (Elmt) loop
+ Install_Spec (Node (Elmt));
+ Install_Formal_Packages (Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ if not In_Body then
+ Push_Scope (S);
+ end if;
+ end Install_Parent;
+
+ -------------------------------
+ -- Install_Hidden_Primitives --
+ -------------------------------
+
+ procedure Install_Hidden_Primitives
+ (Prims_List : in out Elist_Id;
+ Gen_T : Entity_Id;
+ Act_T : Entity_Id)
+ is
+ Elmt : Elmt_Id;
+ List : Elist_Id := No_Elist;
+ Prim_G_Elmt : Elmt_Id;
+ Prim_A_Elmt : Elmt_Id;
+ Prim_G : Node_Id;
+ Prim_A : Node_Id;
+
+ begin
+ -- No action needed in case of serious errors because we cannot trust
+ -- in the order of primitives
+
+ if Serious_Errors_Detected > 0 then
+ return;
+
+ -- No action possible if we don't have available the list of primitive
+ -- operations
+
+ elsif No (Gen_T)
+ or else not Is_Record_Type (Gen_T)
+ or else not Is_Tagged_Type (Gen_T)
+ or else not Is_Record_Type (Act_T)
+ or else not Is_Tagged_Type (Act_T)
+ then
+ return;
+
+ -- There is no need to handle interface types since their primitives
+ -- cannot be hidden
+
+ elsif Is_Interface (Gen_T) then
+ return;
+ end if;
+
+ Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T));
- if Present (Renamed_Entity (Inst_Par)) then
- Inst_Par := Renamed_Entity (Inst_Par);
+ if not Is_Class_Wide_Type (Act_T) then
+ Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T));
+ else
+ Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T)));
end if;
- First_Par := Inst_Par;
-
- Gen_Par :=
- Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
+ loop
+ -- Skip predefined primitives in the generic formal
- First_Gen := Gen_Par;
+ while Present (Prim_G_Elmt)
+ and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt))
+ loop
+ Next_Elmt (Prim_G_Elmt);
+ end loop;
- while Present (Gen_Par)
- and then Is_Child_Unit (Gen_Par)
- loop
- -- Load grandparent instance as well
+ -- Skip predefined primitives in the generic actual
- Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
+ while Present (Prim_A_Elmt)
+ and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt))
+ loop
+ Next_Elmt (Prim_A_Elmt);
+ end loop;
- if Nkind (Name (Inst_Node)) = N_Expanded_Name then
- Inst_Par := Entity (Prefix (Name (Inst_Node)));
+ exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt);
- if Present (Renamed_Entity (Inst_Par)) then
- Inst_Par := Renamed_Entity (Inst_Par);
- end if;
+ Prim_G := Node (Prim_G_Elmt);
+ Prim_A := Node (Prim_A_Elmt);
- Gen_Par :=
- Generic_Parent
- (Specification (Unit_Declaration_Node (Inst_Par)));
+ -- There is no need to handle interface primitives because their
+ -- primitives are not hidden
- if Present (Gen_Par) then
- Prepend_Elmt (Inst_Par, Ancestors);
+ exit when Present (Interface_Alias (Prim_G));
- else
- -- Parent is not the name of an instantiation
+ -- Here we install one hidden primitive
- Install_Noninstance_Specs (Inst_Par);
+ if Chars (Prim_G) /= Chars (Prim_A)
+ and then Has_Suffix (Prim_A, 'P')
+ and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G)
+ then
+ Set_Chars (Prim_A, Chars (Prim_G));
- exit;
+ if List = No_Elist then
+ List := New_Elmt_List;
end if;
- else
- -- Previous error
-
- exit;
+ Append_Elmt (Prim_A, List);
end if;
- end loop;
- if Present (First_Gen) then
- Append_Elmt (First_Par, Ancestors);
+ Next_Elmt (Prim_A_Elmt);
+ Next_Elmt (Prim_G_Elmt);
+ end loop;
- else
- Install_Noninstance_Specs (First_Par);
- end if;
+ -- Append the elements to the list of temporarily visible primitives
+ -- avoiding duplicates.
- if not Is_Empty_Elmt_List (Ancestors) then
- Elmt := First_Elmt (Ancestors);
+ if Present (List) then
+ if No (Prims_List) then
+ Prims_List := New_Elmt_List;
+ end if;
+ Elmt := First_Elmt (List);
while Present (Elmt) loop
- Install_Spec (Node (Elmt));
- Install_Formal_Packages (Node (Elmt));
-
+ Append_Unique_Elmt (Node (Elmt), Prims_List);
Next_Elmt (Elmt);
end loop;
end if;
+ end Install_Hidden_Primitives;
- if not In_Body then
- Push_Scope (S);
+ -------------------------------
+ -- Restore_Hidden_Primitives --
+ -------------------------------
+
+ procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is
+ Prim_Elmt : Elmt_Id;
+ Prim : Node_Id;
+
+ begin
+ if Prims_List /= No_Elist then
+ Prim_Elmt := First_Elmt (Prims_List);
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+ Set_Chars (Prim, Add_Suffix (Prim, 'P'));
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ Prims_List := No_Elist;
end if;
- end Install_Parent;
+ end Restore_Hidden_Primitives;
--------------------------------
-- Instantiate_Formal_Package --
begin
Gen_Scope := Scope (Analyzed_S);
- while Present (Gen_Scope)
- and then Is_Child_Unit (Gen_Scope)
- loop
+ while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop
if Scope (Subp) = Scope (Gen_Scope) then
return True;
end if;
and then Present (Entity (Nam))
then
if not Is_Overloaded (Nam) then
-
if From_Parent_Scope (Entity (Nam)) then
Set_Is_Immediately_Visible (Entity (Nam), False);
Set_Entity (Nam, Empty);
Set_Etype (Nam, Empty);
Analyze (Nam);
-
Set_Is_Immediately_Visible (Entity (Nam));
end if;
begin
Get_First_Interp (Nam, I, It);
-
while Present (It.Nam) loop
if From_Parent_Scope (It.Nam) then
Remove_Interp (I);
Par_Ent : Entity_Id := Empty;
Par_Vis : Boolean := False;
+ Vis_Prims_List : Elist_Id := No_Elist;
+ -- List of primitives made temporarily visible in the instantiation
+ -- to match the visibility of the formal type
+
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
Check_Generic_Actuals (Act_Decl_Id, False);
+ -- Install primitives hidden at the point of the instantiation but
+ -- visible when processing the generic formals
+
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Act_Decl_Id);
+ while Present (E) loop
+ if Is_Type (E)
+ and then Is_Generic_Actual_Type (E)
+ and then Is_Tagged_Type (E)
+ then
+ Install_Hidden_Primitives
+ (Prims_List => Vis_Prims_List,
+ Gen_T => Generic_Parent_Type (Parent (E)),
+ Act_T => E);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end;
+
-- If it is a child unit, make the parent instance (which is an
-- instance of the parent of the generic) visible. The parent
-- instance is the prefix of the name of the generic unit.
Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
end if;
+ Restore_Hidden_Primitives (Vis_Prims_List);
Restore_Private_Views (Act_Decl_Id);
-- Remove the current unit from visibility if this is an instance
procedure Validate_Access_Type_Instance;
procedure Validate_Derived_Type_Instance;
procedure Validate_Derived_Interface_Type_Instance;
+ procedure Validate_Discriminated_Formal_Type;
procedure Validate_Interface_Type_Instance;
procedure Validate_Private_Type_Instance;
- -- These procedures perform validation tests for the named case
+ procedure Validate_Incomplete_Type_Instance;
+ -- These procedures perform validation tests for the named case.
+ -- Validate_Discriminated_Formal_Type is shared by formal private
+ -- types and Ada 2012 formal incomplete types.
function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
-- Check that base types are the same and that the subtypes match
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);
and then not Is_Limited_Type (A_Gen_T)
and then Ada_Version >= Ada_2012
then
- Error_Msg_NE
- ("actual for non-limited & cannot be a limited type", Actual,
- Gen_T);
- Explain_Limited_Type (Act_T, Actual);
- Abandon_Instantiation (Actual);
+ if In_Instance then
+ null;
+ else
+ Error_Msg_NE
+ ("actual for non-limited & cannot be a limited type", Actual,
+ Gen_T);
+ Explain_Limited_Type (Act_T, Actual);
+ Abandon_Instantiation (Actual);
+ end if;
end if;
end Validate_Derived_Type_Instance;
- --------------------------------------
- -- Validate_Interface_Type_Instance --
- --------------------------------------
-
- procedure Validate_Interface_Type_Instance is
- begin
- if not Is_Interface (Act_T) then
- Error_Msg_NE
- ("actual for formal interface type must be an interface",
- Actual, Gen_T);
-
- elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
- or else
- Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
- or else
- Is_Protected_Interface (A_Gen_T) /=
- Is_Protected_Interface (Act_T)
- or else
- Is_Synchronized_Interface (A_Gen_T) /=
- Is_Synchronized_Interface (Act_T)
- then
- Error_Msg_NE
- ("actual for interface& does not match (RM 12.5.5(4))",
- Actual, Gen_T);
- end if;
- end Validate_Interface_Type_Instance;
-
- ------------------------------------
- -- Validate_Private_Type_Instance --
- ------------------------------------
+ ----------------------------------------
+ -- Validate_Discriminated_Formal_Type --
+ ----------------------------------------
- procedure Validate_Private_Type_Instance is
+ procedure Validate_Discriminated_Formal_Type is
Formal_Discr : Entity_Id;
Actual_Discr : Entity_Id;
Formal_Subt : Entity_Id;
begin
- if Is_Limited_Type (Act_T)
- and then not Is_Limited_Type (A_Gen_T)
- then
- Error_Msg_NE
- ("actual for non-limited & cannot be a limited type", Actual,
- Gen_T);
- Explain_Limited_Type (Act_T, Actual);
- Abandon_Instantiation (Actual);
-
- elsif Known_To_Have_Preelab_Init (A_Gen_T)
- and then not Has_Preelaborable_Initialization (Act_T)
- then
- Error_Msg_NE
- ("actual for & must have preelaborable initialization", Actual,
- Gen_T);
-
- elsif Is_Indefinite_Subtype (Act_T)
- and then not Is_Indefinite_Subtype (A_Gen_T)
- and then Ada_Version >= Ada_95
- then
- Error_Msg_NE
- ("actual for & must be a definite subtype", Actual, Gen_T);
-
- elsif not Is_Tagged_Type (Act_T)
- and then Is_Tagged_Type (A_Gen_T)
- then
- Error_Msg_NE
- ("actual for & must be a tagged type", Actual, Gen_T);
-
- elsif Has_Discriminants (A_Gen_T) then
+ if Has_Discriminants (A_Gen_T) then
if not Has_Discriminants (Act_T) then
Error_Msg_NE
("actual for & must have discriminants", Actual, Gen_T);
Abandon_Instantiation (Actual);
end if;
end if;
+ end if;
+ end Validate_Discriminated_Formal_Type;
+
+ ---------------------------------------
+ -- Validate_Incomplete_Type_Instance --
+ ---------------------------------------
+
+ procedure Validate_Incomplete_Type_Instance is
+ begin
+ if not Is_Tagged_Type (Act_T)
+ and then Is_Tagged_Type (A_Gen_T)
+ then
+ Error_Msg_NE
+ ("actual for & must be a tagged type", Actual, Gen_T);
+ end if;
+
+ Validate_Discriminated_Formal_Type;
+ end Validate_Incomplete_Type_Instance;
+
+ --------------------------------------
+ -- Validate_Interface_Type_Instance --
+ --------------------------------------
+
+ procedure Validate_Interface_Type_Instance is
+ begin
+ if not Is_Interface (Act_T) then
+ Error_Msg_NE
+ ("actual for formal interface type must be an interface",
+ Actual, Gen_T);
+
+ elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
+ or else
+ Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
+ or else
+ Is_Protected_Interface (A_Gen_T) /=
+ Is_Protected_Interface (Act_T)
+ or else
+ Is_Synchronized_Interface (A_Gen_T) /=
+ Is_Synchronized_Interface (Act_T)
+ then
+ Error_Msg_NE
+ ("actual for interface& does not match (RM 12.5.5(4))",
+ Actual, Gen_T);
+ end if;
+ end Validate_Interface_Type_Instance;
+
+ ------------------------------------
+ -- Validate_Private_Type_Instance --
+ ------------------------------------
+
+ procedure Validate_Private_Type_Instance is
+ begin
+ if Is_Limited_Type (Act_T)
+ and then not Is_Limited_Type (A_Gen_T)
+ then
+ if In_Instance then
+ null;
+ else
+ Error_Msg_NE
+ ("actual for non-limited & cannot be a limited type", Actual,
+ Gen_T);
+ Explain_Limited_Type (Act_T, Actual);
+ Abandon_Instantiation (Actual);
+ end if;
+
+ elsif Known_To_Have_Preelab_Init (A_Gen_T)
+ and then not Has_Preelaborable_Initialization (Act_T)
+ then
+ Error_Msg_NE
+ ("actual for & must have preelaborable initialization", Actual,
+ Gen_T);
+
+ elsif Is_Indefinite_Subtype (Act_T)
+ and then not Is_Indefinite_Subtype (A_Gen_T)
+ and then Ada_Version >= Ada_95
+ then
+ Error_Msg_NE
+ ("actual for & must be a definite subtype", Actual, Gen_T);
+ elsif not Is_Tagged_Type (Act_T)
+ and then Is_Tagged_Type (A_Gen_T)
+ then
+ Error_Msg_NE
+ ("actual for & must be a tagged type", Actual, Gen_T);
end if;
+ Validate_Discriminated_Formal_Type;
Ancestor := Gen_T;
end Validate_Private_Type_Instance;
and then
Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
then
- if Is_Class_Wide_Type (Act_T)
+ -- If the formal is an incomplete type, the actual can be
+ -- incomplete as well.
+
+ if Ekind (A_Gen_T) = E_Incomplete_Type then
+ null;
+
+ elsif Is_Class_Wide_Type (Act_T)
or else No (Full_View (Act_T))
then
Error_Msg_N ("premature use of incomplete type", Actual);
and then not Is_Derived_Type (Act_T)
and then No (Full_View (Root_Type (Act_T)))
then
- Error_Msg_N ("premature use of private type", Actual);
+ -- If the formal is an incomplete type, the actual can be
+ -- private or incomplete as well.
+
+ if Ekind (A_Gen_T) = E_Incomplete_Type then
+ null;
+ else
+ Error_Msg_N ("premature use of private type", Actual);
+ end if;
elsif Has_Private_Component (Act_T) then
Error_Msg_N
when N_Formal_Private_Type_Definition =>
Validate_Private_Type_Instance;
+ when N_Formal_Incomplete_Type_Definition =>
+ Validate_Incomplete_Type_Instance;
+
when N_Formal_Derived_Type_Definition =>
Validate_Derived_Type_Instance;
Set_Generic_Parent_Type (Decl_Node, Ancestor);
end if;
- elsif Nkind (Def) = N_Formal_Private_Type_Definition then
+ elsif Nkind_In (Def,
+ N_Formal_Private_Type_Definition,
+ N_Formal_Incomplete_Type_Definition)
+ then
Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
end if;
procedure Reset_Entity (N : Node_Id) is
procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
- -- If the type of N2 is global to the generic unit. Save the type in
- -- the generic node.
- -- What does this comment mean???
+ -- If the type of N2 is global to the generic unit, save the type in
+ -- the generic node. Just as we perform name capture for explicit
+ -- references within the generic, we must capture the global types
+ -- of local entities because they may participate in resolution in
+ -- the instance.
function Top_Ancestor (E : Entity_Id) return Entity_Id;
-- Find the ultimate ancestor of the current unit. If it is not a
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 the node is an entry call to an entry in an enclosing task,
+ -- it is rewritten as a selected component. No global entity to
+ -- preserve in this case, since the expansion will be redone in
+ -- the instance.
+
+ if not Nkind_In (E, N_Defining_Identifier,
+ N_Defining_Character_Literal,
+ N_Defining_Operator_Symbol)
+ then
+ Set_Associated_Node (N, Empty);
+ Set_Etype (N, Empty);
+ return;
+ end if;
+
+ -- 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 Is_Itype (E)
and then Ekind (E) = E_Access_Subtype
and then Is_Entity_Name (N)
Save_Entity_Descendants (N);
else
+ Set_Is_Prefixed_Call (Parent (N));
Set_Associated_Node (N, Empty);
Set_Etype (N, Empty);
end if;
-- In Ada 2005, X.F may be a call to a primitive operation,
-- rewritten as F (X). This rewriting will be done again in an
-- instance, so keep the original node. Global entities will be
- -- captured as for other constructs.
+ -- captured as for other constructs. Indicate that this must
+ -- resolve as a call, to prevent accidental overloading in the
+ -- instance, if both a component and a primitive operation appear
+ -- as candidates.
else
- null;
+ Set_Is_Prefixed_Call (Parent (N));
end if;
-- Entity is local. Reset in generic unit, so that node is resolved
-- All other cases than aggregates
else
- -- For pragmas, we propagate the Enabled status for the
- -- relevant pragmas to the original generic tree. This was
- -- originally needed for SCO generation. It is no longer
- -- needed there (since we use the Sloc value in calls to
- -- Set_SCO_Pragma_Enabled), but it seems a generally good
- -- idea to have this flag set properly.
-
- if Nkind (N) = N_Pragma
- and then
- (Pragma_Name (N) = Name_Assert or else
- Pragma_Name (N) = Name_Check or else
- Pragma_Name (N) = Name_Precondition or else
- Pragma_Name (N) = Name_Postcondition)
- and then Present (Associated_Node (Pragma_Identifier (N)))
- then
- Set_Pragma_Enabled (N,
- Pragma_Enabled
- (Parent (Associated_Node (Pragma_Identifier (N)))));
- end if;
-
Save_Global_Descendant (Field1 (N));
Save_Global_Descendant (Field2 (N));
Save_Global_Descendant (Field3 (N));
end if;
end;
end if;
+
+ -- If a node has aspects, references within their expressions must
+ -- be saved separately, given that they are not directly in the
+ -- tree.
+
+ if Has_Aspects (N) then
+ declare
+ Aspect : Node_Id;
+ begin
+ Aspect := First (Aspect_Specifications (N));
+ while Present (Aspect) loop
+ Save_Global_References (Expression (Aspect));
+ Next (Aspect);
+ end loop;
+ end;
+ end if;
end Save_References;
-- Start of processing for Save_Global_References
end loop;
end Switch_View;
+ -----------------
+ -- True_Parent --
+ -----------------
+
+ function True_Parent (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (Parent (N)) = N_Subunit then
+ return Parent (Corresponding_Stub (Parent (N)));
+ else
+ return Parent (N);
+ end if;
+ end True_Parent;
+
-----------------------------
-- Valid_Default_Attribute --
-----------------------------
OSDN Git Service
