-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
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_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN;
-- Verify that the actuals of the actual instance match the actuals of
-- the template for a formal package that is not declared with a box.
- procedure Check_Forward_Instantiation (N : Node_Id; Decl : Node_Id);
+ procedure Check_Forward_Instantiation (Decl : Node_Id);
-- If the generic is a local entity and the corresponding body has not
-- been seen yet, flag enclosing packages to indicate that it will be
-- elaborated after the generic body. Subprograms declared in the same
-- of the instance can be placed after the freeze node of the parent,
-- which it itself an instance.
+ procedure Set_Instance_Env
+ (Gen_Unit : Entity_Id;
+ Act_Unit : Entity_Id);
+ -- Save current instance on saved environment, to be used to determine
+ -- the global status of entities in nested instances. Part of Save_Env.
+ -- called after verifying that the generic unit is legal for the instance.
+
procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
-- Associate analyzed generic parameter with corresponding
-- instance. Used for semantic checks at instantiation time.
-- the instance and the generic, so that the back-end can establish the
-- proper order of elaboration.
+ procedure Init_Env;
+ -- Establish environment for subsequent instantiation. Separated from
+ -- Save_Env because data-structures for visibility handling must be
+ -- initialized before call to Check_Generic_Child_Unit.
+
procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
-- When compiling an instance of a child unit the parent (which is
-- itself an instance) is an enclosing scope that must be made
function Instantiate_Type
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
+ Analyzed_Formal : Node_Id;
+ Actual_Decls : List_Id)
return Node_Id;
function Instantiate_Formal_Subprogram
-- those nodes that contain global information. At instantiation, the
-- information from the associated node is placed on the new copy, so
-- that name resolution is not repeated.
-
- -- Three kinds of nodes have associated nodes:
-
- -- a) those that contain entities, that is to say identifiers,
- -- expanded_names, and operators (N_Has_Entity)
-
+ --
+ -- Three kinds of source nodes have associated nodes:
+ --
+ -- a) those that can reference (denote) entities, that is identifiers,
+ -- character literals, expanded_names, operator symbols, operators,
+ -- and attribute reference nodes. These nodes have an Entity field
+ -- and are the set of nodes that are in N_Has_Entity.
+ --
-- b) aggregates (N_Aggregate and N_Extension_Aggregate)
-
+ --
-- c) selected components (N_Selected_Component)
-
+ --
-- For the first class, the associated node preserves the entity if it is
- -- global. If the generic contains nested instantiations, the associated_
+ -- global. If the generic contains nested instantiations, the associated
-- node itself has been recopied, and a chain of them must be followed.
-
+ --
-- For aggregates, the associated node allows retrieval of the type, which
-- may otherwise not appear in the generic. The view of this type may be
-- different between generic and instantiation, and the full view can be
-- type extensions, the same view exchange may have to be performed for
-- some of the ancestor types, if their view is private at the point of
-- instantiation.
-
- -- Query??? why selected components. What about N_Freeze_Nodes, I assume
- -- that the answer is no, which means that the comment above for a) is
- -- confusing ???
-
+ --
+ -- Nodes that are selected components in the parse tree may be rewritten
+ -- as expanded names after resolution, and must be treated as potential
+ -- entity holders. which is why they also have an Associated_Node.
+ --
+ -- Nodes that do not come from source, such as freeze nodes, do not appear
+ -- in the generic tree, and need not have an associated node.
+ --
-- The associated node is stored in the Associated_Node field. Note that
-- this field overlaps Entity, which is fine, because the whole point is
-- that we don't need or want the normal Entity field in this situation.
-- Because instantiations can be recursive, the following must be saved
-- on entry and restored on exit from an instantiation (spec or body).
- -- This is done by the two procedures Save_Env and Restore_Env.
+ -- This is done by the two procedures Save_Env and Restore_Env. For
+ -- package and subprogram instantiations (but not for the body instances)
+ -- the action of Save_Env is done in two steps: Init_Env is called before
+ -- Check_Generic_Child_Unit, because setting the parent instances requires
+ -- that the visibility data structures be properly initialized. Once the
+ -- generic is unit is validated, Set_Instance_Env completes Save_Env.
type Instance_Env is record
- Ada_83 : Boolean;
+ Ada_Version : Ada_Version_Type;
Instantiated_Parent : Assoc;
Exchanged_Views : Elist_Id;
Hidden_Entities : Elist_Id;
F_Copy : List_Id)
return List_Id
is
- Actuals : List_Id := Generic_Associations (I_Node);
+ 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;
- Actual_Types : Elist_Id := New_Elmt_List;
- Assoc : List_Id := New_List;
Formal : Node_Id;
Next_Formal : Node_Id;
Temp_Formal : Node_Id;
Analyzed_Formal : Node_Id;
- Defaults : Elist_Id := New_Elmt_List;
Match : Node_Id;
Named : Node_Id;
First_Named : Node_Id := Empty;
Found := Explicit_Generic_Actual_Parameter (Actual);
Set_Entity (Selector_Name (Actual), A_F);
Set_Etype (Selector_Name (Actual), Etype (A_F));
+ Generate_Reference (A_F, Selector_Name (Actual));
Found_Assoc := Actual;
Num_Matched := Num_Matched + 1;
exit;
-- If named associations are present, save the first named association
-- (it may of course be Empty) to facilitate subsequent name search.
+ Actuals := Generic_Associations (I_Node);
+
if Present (Actuals) then
First_Named := First (Actuals);
Abandon_Instantiation (Named);
end if;
- Num_Actuals := Num_Actuals + 1;
+ -- A named association may lack an actual parameter, if it was
+ -- introduced for a default subprogram that turns out to be local
+ -- to the outer instantiation.
+
+ if Present (Explicit_Generic_Actual_Parameter (Named)) then
+ Num_Actuals := Num_Actuals + 1;
+ end if;
+
Next (Named);
end loop;
Defining_Identifier (Analyzed_Formal));
if No (Match) then
- Error_Msg_NE ("missing actual for instantiation of &",
- Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_Sloc := Sloc (Gen_Unit);
+ Error_Msg_NE
+ ("missing actual&",
+ Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
else
Analyze (Match);
Append_To (Assoc,
- Instantiate_Type (Formal, Match, Analyzed_Formal));
+ Instantiate_Type
+ (Formal, Match, Analyzed_Formal, Assoc));
-- an instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package.
Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then
+ Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
- ("missing actual for instantiation of&",
- Instantiation_Node,
- Defining_Identifier (Formal));
+ ("missing actual&",
+ Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
end loop;
if Num_Actuals > Num_Matched then
- Error_Msg_N
- ("unmatched actuals in instantiation", Instantiation_Node);
+ Error_Msg_Sloc := Sloc (Gen_Unit);
+
+ if Present (Selector_Name (Actual)) then
+ Error_Msg_NE
+ ("unmatched actual&",
+ Actual, Selector_Name (Actual));
+ Error_Msg_NE ("\in instantiation of& declared#",
+ Actual, Gen_Unit);
+ else
+ Error_Msg_NE
+ ("unmatched actual in instantiation of& declared#",
+ Actual, Gen_Unit);
+ end if;
end if;
elsif Present (Actuals) then
Error_Msg_N ("premature usage of incomplete type", Def);
elsif Is_Internal (Component_Type (T))
- and then Nkind (Original_Node (Subtype_Indication (Def)))
+ and then Nkind (Original_Node
+ (Subtype_Indication (Component_Definition (Def))))
/= N_Attribute_Reference
then
Error_Msg_N
("only a subtype mark is allowed in a formal",
- Subtype_Indication (Def));
+ Subtype_Indication (Component_Definition (Def)));
end if;
end Analyze_Formal_Array_Type;
Set_Small_Value (T, Delta_Val);
Set_Scalar_Range (T, Scalar_Range (Base));
+ Check_Restriction (No_Fixed_Point, Def);
end Analyze_Formal_Decimal_Fixed_Point_Type;
---------------------------------
Def : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Def);
+ Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N);
New_N : Node_Id;
- Unk_Disc : Boolean := Unknown_Discriminants_Present (N);
begin
Set_Is_Generic_Type (T);
Set_Digits_Value (Base, Digits_Value (Standard_Float));
Set_Scalar_Range (Base, Scalar_Range (Standard_Float));
Set_Parent (Base, Parent (Def));
+
+ Check_Restriction (No_Floating_Point, Def);
end Analyze_Formal_Floating_Type;
---------------------------------
procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
E : constant Node_Id := Expression (N);
- Id : Node_Id := Defining_Identifier (N);
+ Id : constant Node_Id := Defining_Identifier (N);
K : Entity_Kind;
T : Node_Id;
end if;
if K = E_Generic_In_Parameter then
- if Is_Limited_Type (T) then
+
+ -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
+
+ 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);
end if;
if Is_Abstract (T) then
end if;
if Present (E) then
- Analyze_Default_Expression (E, T);
+ Analyze_Per_Use_Expression (E, T);
end if;
Set_Ekind (Id, K);
Set_Delta_Value (Base, Ureal_1);
Set_Scalar_Range (Base, Scalar_Range (T));
Set_Parent (Base, Parent (Def));
+
+ Check_Restriction (No_Fixed_Point, Def);
end Analyze_Formal_Ordinary_Fixed_Point_Type;
----------------------------
procedure Analyze_Formal_Package (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Formal : Entity_Id := Defining_Identifier (N);
- Gen_Id : constant Node_Id := Name (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;
New_N : Node_Id;
begin
Text_IO_Kludge (Gen_Id);
+ Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
if Ekind (Gen_Unit) /= E_Generic_Package then
Error_Msg_N ("expect generic package name", Gen_Id);
+ Restore_Env;
return;
elsif Gen_Unit = Current_Scope then
Error_Msg_N
("generic package cannot be used as a formal package of itself",
Gen_Id);
+ Restore_Env;
return;
+
+ elsif In_Open_Scopes (Gen_Unit) then
+ if Is_Compilation_Unit (Gen_Unit)
+ and then Is_Child_Unit (Current_Scope)
+ then
+ -- Special-case the error when the formal is a parent, and
+ -- continue analysis to minimize cascaded errors.
+
+ Error_Msg_N
+ ("generic parent cannot be used as formal package "
+ & "of a child unit",
+ Gen_Id);
+
+ else
+ Error_Msg_N
+ ("generic package cannot be used as a formal package "
+ & "within itself",
+ Gen_Id);
+ Restore_Env;
+ return;
+ end if;
end if;
-- Check for a formal package that is a package renaming.
-- and analyze it like a regular package, except that we treat the
-- formals as additional visible components.
- Save_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;
Subp : Entity_Id;
begin
+ if Nam = Error then
+ return;
+ end if;
+
if Nkind (Nam) = N_Defining_Program_Unit_Name then
Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
return;
Resolve (Def, (Etype (Nam)));
- elsif (not Is_Entity_Name (Def)
- or else not Is_Overloadable (Entity (Def)))
+ elsif not Is_Entity_Name (Def)
+ or else not Is_Overloadable (Entity (Def))
then
Error_Msg_N ("expect valid subprogram name as default", Def);
return;
-- Enter the new name, and branch to specific routine.
case Nkind (Def) is
- when N_Formal_Private_Type_Definition
- => Analyze_Formal_Private_Type (N, T, Def);
+ when N_Formal_Private_Type_Definition =>
+ Analyze_Formal_Private_Type (N, T, Def);
+
+ when N_Formal_Derived_Type_Definition =>
+ Analyze_Formal_Derived_Type (N, T, Def);
- when N_Formal_Derived_Type_Definition
- => Analyze_Formal_Derived_Type (N, T, Def);
+ when N_Formal_Discrete_Type_Definition =>
+ Analyze_Formal_Discrete_Type (T, Def);
- when N_Formal_Discrete_Type_Definition
- => Analyze_Formal_Discrete_Type (T, Def);
+ when N_Formal_Signed_Integer_Type_Definition =>
+ Analyze_Formal_Signed_Integer_Type (T, Def);
- when N_Formal_Signed_Integer_Type_Definition
- => Analyze_Formal_Signed_Integer_Type (T, Def);
+ when N_Formal_Modular_Type_Definition =>
+ Analyze_Formal_Modular_Type (T, Def);
- when N_Formal_Modular_Type_Definition
- => Analyze_Formal_Modular_Type (T, Def);
+ when N_Formal_Floating_Point_Definition =>
+ Analyze_Formal_Floating_Type (T, Def);
- when N_Formal_Floating_Point_Definition
- => Analyze_Formal_Floating_Type (T, Def);
+ when N_Formal_Ordinary_Fixed_Point_Definition =>
+ Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
- when N_Formal_Ordinary_Fixed_Point_Definition
- => Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
+ when N_Formal_Decimal_Fixed_Point_Definition =>
+ Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
- when N_Formal_Decimal_Fixed_Point_Definition
- => Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
+ when N_Array_Type_Definition =>
+ Analyze_Formal_Array_Type (T, Def);
- when N_Array_Type_Definition
- => Analyze_Formal_Array_Type (T, Def);
+ when N_Access_To_Object_Definition |
+ N_Access_Function_Definition |
+ N_Access_Procedure_Definition =>
+ Analyze_Generic_Access_Type (T, Def);
- when N_Access_To_Object_Definition |
- N_Access_Function_Definition |
- N_Access_Procedure_Definition
- => Analyze_Generic_Access_Type (T, Def);
+ when N_Error =>
+ null;
- when others =>
+ when others =>
raise Program_Error;
end case;
Set_Is_Generic_Type (T);
-
end Analyze_Formal_Type_Declaration;
------------------------------------
Analyze (Gen_Parm_Decl);
Next (Gen_Parm_Decl);
end loop;
+
+ Generate_Reference_To_Generic_Formals (Current_Scope);
end Analyze_Generic_Formal_Part;
------------------------------------------
------------------------------------------
procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Id : Entity_Id;
New_N : Node_Id;
Save_Parent : Node_Id;
+ Renaming : Node_Id;
+ Decls : constant List_Id :=
+ Visible_Declarations (Specification (N));
+ Decl : Node_Id;
begin
+ -- 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
+ -- entity named P may hide it, so that the usual visibility rules in
+ -- the instance will not resolve properly.
+
+ Renaming :=
+ Make_Package_Renaming_Declaration (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
+ Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
+
+ if Present (Decls) then
+ Decl := First (Decls);
+ while Present (Decl)
+ and then Nkind (Decl) = N_Pragma
+ loop
+ Next (Decl);
+ end loop;
+
+ if Present (Decl) then
+ Insert_Before (Decl, Renaming);
+ else
+ Append (Renaming, Visible_Declarations (Specification (N)));
+ end if;
+
+ else
+ Set_Visible_Declarations (Specification (N), New_List (Renaming));
+ end if;
+
-- 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_Categorization_From_Pragmas (N);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
+ -- Link the declaration of the generic homonym in the generic copy
+ -- to the package it renames, so that it is always resolved properly.
+
+ Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
+ Set_Entity (Associated_Node (Name (Renaming)), Id);
+
-- For a library unit, we have reconstructed the entity for the
-- unit, and must reset it in the library tables.
else
Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
Validate_RT_RAT_Component (N);
- end if;
+ -- If this is a spec without a body, check that generic parameters
+ -- are referenced.
+
+ if not Body_Required (Parent (N)) then
+ Check_References (Id);
+ end if;
+ end if;
end Analyze_Generic_Package_Declaration;
--------------------------------------------
Enter_Name (Id);
+ Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
New_Scope (Id);
+ Enter_Generic_Scope (Id);
Set_Inner_Instances (Id, New_Elmt_List);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Formals := Parameter_Specifications (Spec);
if Present (Formals) then
- Process_Formals (Id, Formals, Spec);
+ Process_Formals (Formals, Spec);
end if;
if Nkind (Spec) = N_Function_Specification then
End_Generic;
End_Scope;
-
+ Exit_Generic_Scope (Id);
+ Generate_Reference_To_Formals (Id);
end Analyze_Generic_Subprogram_Declaration;
-----------------------------------
-- node. This should really be noted in the spec! ???
procedure Analyze_Package_Instantiation (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Gen_Id : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Gen_Id : constant Node_Id := Name (N);
Act_Decl : Node_Id;
Act_Decl_Name : Node_Id;
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
- Is_Actual_Pack : Boolean := Is_Internal (Defining_Entity (N));
+ Is_Actual_Pack : constant Boolean :=
+ Is_Internal (Defining_Entity (N));
+
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
Unit_Renaming : Node_Id;
Generate_Definition (Act_Decl_Id);
Pre_Analyze_Actuals (N);
+ Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
-- Verify that it is the name of a generic package
if Etype (Gen_Unit) = Any_Type then
+ Restore_Env;
return;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
- Error_Msg_N
- ("expect name of generic package in instantiation", Gen_Id);
+
+ -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
+
+ if From_With_Type (Gen_Unit) then
+ Error_Msg_N
+ ("cannot instantiate a limited withed package", Gen_Id);
+ else
+ Error_Msg_N
+ ("expect name of generic package in instantiation", Gen_Id);
+ end if;
+
+ Restore_Env;
return;
end if;
("& is hidden within declaration of instance ", Prefix (Gen_Id));
end if;
- -- If renaming, indicate this is an instantiation of renamed unit.
+ Set_Entity (Gen_Id, Gen_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
then
Gen_Unit := Renamed_Object (Gen_Unit);
- Set_Entity (Gen_Id, Gen_Unit);
end if;
-- Verify that there are no circular instantiations.
if In_Open_Scopes (Gen_Unit) then
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
+ Restore_Env;
return;
elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
Error_Msg_NE
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
+ Restore_Env;
return;
else
- Save_Env (Gen_Unit, Act_Decl_Id);
+ Set_Instance_Env (Gen_Unit, Act_Decl_Id);
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
-- Initialize renamings map, for error checking, and the list
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
- Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation.
declare
Enclosing_Body_Present : Boolean := False;
+ -- If the generic unit is not a compilation unit, then a body
+ -- may be present in its parent even if none is required. We
+ -- create a tentative pending instantiation for the body, which
+ -- will be discarded if none is actually present.
+
Scop : Entity_Id;
begin
exit;
end if;
+ exit when Is_Compilation_Unit (Scop);
Scop := Scope (Scop);
end loop;
end if;
-- If front-end inlining is enabled, and this is a unit for which
-- code will be generated, we instantiate the body at once.
-- This is done if the instance is not the main unit, and if the
- -- generic is not a child unit, to avoid scope problems.
+ -- generic is not a child unit of another generic, to avoid scope
+ -- problems and the reinstallation of parent instances.
if Front_End_Inlining
and then Expander_Active
- and then not Is_Child_Unit (Gen_Unit)
+ 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 Nkind (Parent (N)) /= N_Compilation_Unit
and then Might_Inline_Subp
+ and then not Is_Actual_Pack
then
Inline_Now := True;
end if;
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
- and then Tree_Output));
+ and then ASIS_Mode));
-- If front_end_inlining is enabled, do not instantiate a
-- body if within a generic context.
Needs_Body := False;
end if;
+ -- If the current context is generic, and the package being
+ -- instantiated is declared within a formal package, there
+ -- is no body to instantiate until the enclosing generic is
+ -- instantiated, and there is an actual for the formal
+ -- package. If the formal package has parameters, we build a
+ -- regular package instance for it, that preceeds the original
+ -- formal package declaration.
+
+ if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
+ declare
+ Decl : constant Node_Id :=
+ Original_Node
+ (Unit_Declaration_Node (Scope (Gen_Unit)));
+ 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)) = N_Formal_Package_Declaration)
+ then
+ Needs_Body := False;
+ end if;
+ end;
+ end if;
end;
-- If we are generating the calling stubs from the instantiation
-- and that cleanup actions should be delayed until after the
-- instance body is expanded.
- Check_Forward_Instantiation (N, Gen_Decl);
+ Check_Forward_Instantiation (Gen_Decl);
if Nkind (N) = N_Package_Instantiation then
declare
Enclosing_Master : Entity_Id := Current_Scope;
elsif Ekind (Enclosing_Master) = E_Generic_Package then
Enclosing_Master := Scope (Enclosing_Master);
- elsif Ekind (Enclosing_Master) = E_Generic_Function
- or else Ekind (Enclosing_Master) = E_Generic_Procedure
+ elsif Is_Generic_Subprogram (Enclosing_Master)
or else Ekind (Enclosing_Master) = E_Void
then
-- Cleanup actions will eventually be performed on
Set_Instance_Spec (N, Act_Decl);
- -- Case of not a compilation unit
+ -- If not a compilation unit, insert the package declaration
+ -- before the original instantiation node.
if Nkind (Parent (N)) /= N_Compilation_Unit then
Mark_Rewrite_Insertion (Act_Decl);
Insert_Before (N, Act_Decl);
Analyze (Act_Decl);
- -- Case of compilation unit that is generic instantiation
-
- -- Place declaration on current node so context is complete
- -- for analysis (including nested instantiations).
+ -- For an instantiation that is a compilation unit, place
+ -- declaration on current node so context is complete
+ -- for analysis (including nested instantiations). It this
+ -- is the main unit, the declaration eventually replaces the
+ -- instantiation node. If the instance body is later created, it
+ -- replaces the instance node, and the declation is attached to
+ -- it (see Build_Instance_Compilation_Unit_Nodes).
else
if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
-- same time as the spec instantiation.
Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
- Set_Suppress_Elaboration_Checks (Act_Decl_Id);
+ Set_Kill_Elaboration_Checks (Act_Decl_Id);
end if;
Check_Elab_Instantiation (N);
Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
First_Private_Entity (Act_Decl_Id));
+ -- If the instantiation will receive a body, the unit will
+ -- be transformed into a package body, and receive its own
+ -- elaboration entity. Otherwise, the nature of the unit is
+ -- now a package declaration.
+
if Nkind (Parent (N)) = N_Compilation_Unit
- and then not Needs_Body
+ and then not Needs_Body
then
Rewrite (N, Act_Decl);
end if;
if Parent_Installed then
Remove_Parent;
end if;
-
end Analyze_Package_Instantiation;
---------------------------
S : Entity_Id;
begin
- -- Case of generic unit defined in another unit
+ -- Case of generic unit defined in another unit. We must remove
+ -- the complete context of the current unit to install that of
+ -- the generic.
if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
- Vis := Is_Immediately_Visible (Gen_Comp);
-
S := Current_Scope;
while Present (S)
S := Scope (S);
end loop;
- -- Find and save all enclosing instances.
+ Vis := Is_Immediately_Visible (Gen_Comp);
+
+ -- Find and save all enclosing instances
S := Current_Scope;
if Is_Generic_Instance (S) then
N_Instances := N_Instances + 1;
Instances (N_Instances) := S;
+
+ exit when In_Package_Body (S);
end if;
S := Scope (S);
-- Remove context of current compilation unit, unless we
-- are within a nested package instantiation, in which case
-- the context has been removed previously.
+
-- If current scope is the body of a child unit, remove context
-- of spec as well.
and then S /= Standard_Standard
loop
exit when Is_Generic_Instance (S)
- and then In_Package_Body (S);
+ and then (In_Package_Body (S)
+ or else Ekind (S) = E_Procedure
+ or else Ekind (S) = E_Function);
if S = Curr_Unit
or else (Ekind (Curr_Unit) = E_Package_Body
and then S = Spec_Entity (Curr_Unit))
+ or else (Ekind (Curr_Unit) = E_Subprogram_Body
+ and then S =
+ Corresponding_Spec
+ (Unit_Declaration_Node (Curr_Unit)))
then
Removed := True;
+ -- Remove entities in current scopes from visibility, so
+ -- than instance body is compiled in a clean environment.
+
+ Save_Scope_Stack (Handle_Use => False);
+
if Is_Child_Unit (S) then
+
-- Remove child unit from stack, as well as inner scopes.
- -- Removing its context of child unit will remove parent
+ -- Removing the context of a child unit removes parent
-- units as well.
while Current_Scope /= S loop
S := Scope (S);
end loop;
+ New_Scope (Standard_Standard);
+ Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
Instantiate_Package_Body
- ((N, Act_Decl, Expander_Active, Current_Sem_Unit));
+ ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
+ Pop_Scope;
- -- Restore context.
+ -- Restore context
Set_Is_Immediately_Visible (Gen_Comp, Vis);
end loop;
if Removed then
- -- Make local entities not visible, so that when the context of
- -- unit is restored, there are not spurious hidings of use-
- -- visible entities (which appear in the environment before the
- -- current scope).
-
- if Current_Scope /= Standard_Standard then
- S := First_Entity (Current_Scope);
-
- while Present (S) loop
- if Is_Overloadable (S) then
- Set_Is_Immediately_Visible (S, False);
- end if;
-
- Next_Entity (S);
- end loop;
- end if;
-
Install_Context (Curr_Comp);
- if Current_Scope /= Standard_Standard then
- S := First_Entity (Current_Scope);
-
- while Present (S) loop
- if Is_Overloadable (S) then
- Set_Is_Immediately_Visible (S);
- end if;
-
- Next_Entity (S);
- end loop;
- end if;
-
if Present (Curr_Scope)
and then Is_Child_Unit (Curr_Scope)
then
New_Scope (Inner_Scopes (J));
end loop;
end if;
+
+ Restore_Scope_Stack (Handle_Use => False);
end if;
- for J in reverse 1 .. Num_Scopes loop
- Install_Use_Clauses (Use_Clauses (J));
- end loop;
+ -- 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
+ then
+ for J in reverse 1 .. Num_Inner + 1 loop
+ Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
+ Use_Clauses (J);
+ Install_Use_Clauses (Use_Clauses (J));
+ end loop;
+
+ else
+ for J in reverse 1 .. Num_Scopes loop
+ Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
+ Use_Clauses (J);
+ Install_Use_Clauses (Use_Clauses (J));
+ end loop;
+ end if;
for J in 1 .. N_Instances loop
Set_Is_Generic_Instance (Instances (J), True);
else
Instantiate_Package_Body
- ((N, Act_Decl, Expander_Active, Current_Sem_Unit));
+ ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
end if;
end Inline_Instance_Body;
(N : Node_Id;
K : Entity_Kind)
is
- Loc : constant Source_Ptr := Sloc (N);
- Gen_Id : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Gen_Id : constant Node_Id := Name (N);
- Act_Decl_Id : Entity_Id;
- Anon_Id : Entity_Id :=
- Make_Defining_Identifier
- (Sloc (Defining_Entity (N)),
- New_External_Name
+ Anon_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (Defining_Entity (N)),
+ Chars => New_External_Name
(Chars (Defining_Entity (N)), 'R'));
- Act_Decl : Node_Id;
- Act_Spec : Node_Id;
- Act_Tree : Node_Id;
+
+ Act_Decl_Id : Entity_Id;
+ Act_Decl : Node_Id;
+ Act_Spec : Node_Id;
+ Act_Tree : Node_Id;
Gen_Unit : Entity_Id;
Gen_Decl : Node_Id;
Pack_Id : Entity_Id;
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
- Spec : Node_Id;
procedure Analyze_Instance_And_Renamings;
-- The instance must be analyzed in a context that includes the
-- has the same name as the instantiation, to insure that the
-- binder calls the elaboration procedure with the right name.
-- Copy the entity of the instance, which may have compilation
- -- level flags (eg. is_child_unit) set.
+ -- level flags (e.g. Is_Child_Unit) set.
Pack_Id := New_Copy (Def_Ent);
Set_Instance_Spec (N, Pack_Decl);
Set_Is_Generic_Instance (Pack_Id);
+ Set_Needs_Debug_Info (Pack_Id);
-- Case of not a compilation unit
-- Set name and scope of internal subprogram so that the
-- proper external name will be generated. The proper scope
- -- is the scope of the wrapper package.
+ -- is the scope of the wrapper package. We need to generate
+ -- debugging information for the internal subprogram, so set
+ -- flag accordingly.
Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
Set_Scope (Anon_Id, Scope (Pack_Id));
+
+ -- Mark wrapper package as referenced, to avoid spurious
+ -- warnings if the instantiation appears in various with_
+ -- clauses of subunits of the main unit.
+
+ Set_Referenced (Pack_Id);
end if;
Set_Is_Generic_Instance (Anon_Id);
+ Set_Needs_Debug_Info (Anon_Id);
Act_Decl_Id := New_Copy (Anon_Id);
Set_Parent (Act_Decl_Id, Parent (Anon_Id));
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
- Set_Suppress_Elaboration_Checks (Act_Decl_Id);
+ Set_Kill_Elaboration_Checks (Act_Decl_Id);
Set_Is_Compilation_Unit (Anon_Id);
Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
Instantiation_Node := N;
Pre_Analyze_Actuals (N);
+ Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
end if;
- if Etype (Gen_Unit) = Any_Type then return; end if;
+ if Etype (Gen_Unit) = Any_Type then
+ Restore_Env;
+ return;
+ end if;
-- Verify that it is a generic subprogram of the right kind, and that
-- it does not lead to a circular instantiation.
elsif In_Open_Scopes (Gen_Unit) then
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
- elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
- Error_Msg_Node_2 := Current_Scope;
- Error_Msg_NE
- ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
- Circularity_Detected := True;
-
elsif K = E_Procedure
and then Ekind (Gen_Unit) /= E_Generic_Procedure
then
end if;
else
- -- If renaming, indicate that this is instantiation of renamed unit
+ Set_Entity (Gen_Id, Gen_Unit);
+ Set_Is_Instantiated (Gen_Unit);
+
+ if In_Extended_Main_Source_Unit (N) then
+ Generate_Reference (Gen_Unit, N);
+ end if;
+
+ -- If renaming, get original unit
if Present (Renamed_Object (Gen_Unit))
and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
then
Gen_Unit := Renamed_Object (Gen_Unit);
- Set_Entity (Gen_Id, Gen_Unit);
- end if;
-
- if In_Extended_Main_Source_Unit (N) then
Set_Is_Instantiated (Gen_Unit);
Generate_Reference (Gen_Unit, N);
end if;
+ if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
+ Error_Msg_Node_2 := Current_Scope;
+ Error_Msg_NE
+ ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
+ Circularity_Detected := True;
+ return;
+ end if;
+
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
- Spec := Specification (Gen_Decl);
-- The subprogram itself cannot contain a nested instance, so
-- the current parent is left empty.
- Save_Env (Gen_Unit, Empty);
+ Set_Instance_Env (Gen_Unit, Empty);
-- Initialize renamings map, for error checking.
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
- Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation.
Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
- Check_Elab_Instantiation (N);
+ 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 ???
or else Is_Inlined (Act_Decl_Id))
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
- and then Tree_Output))
- and then (Expander_Active or else Tree_Output)
+ and then ASIS_Mode))
+ and then (Expander_Active or else ASIS_Mode)
and then not ABE_Is_Certain (N)
and then not Is_Eliminated (Act_Decl_Id)
then
Pending_Instantiations.Increment_Last;
Pending_Instantiations.Table (Pending_Instantiations.Last) :=
(N, Act_Decl, Expander_Active, Current_Sem_Unit);
- Check_Forward_Instantiation (N, Gen_Decl);
+ Check_Forward_Instantiation (Gen_Decl);
-- The wrapper package is always delayed, because it does
-- not constitute a freeze point, but to insure that the
if Parent_Installed then
Remove_Parent;
end if;
-
end Analyze_Subprogram_Instantiation;
-------------------------
Set_Library_Unit (Decl_Cunit, Body_Cunit);
Set_Library_Unit (Body_Cunit, Decl_Cunit);
+ -- Preserve the private nature of the package if needed.
+
+ Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
+
+ -- If the instance is not the main unit, its context, categorization,
+ -- and elaboration entity are not relevant to the compilation.
+
+ if Parent (N) /= Cunit (Main_Unit) then
+ return;
+ end if;
+
-- The context clause items on the instantiation, which are now
-- attached to the body compilation unit (since the body overwrote
-- the original instantiation node), semantically belong on the spec,
-- 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
elsif Is_Integer_Type (Etype (E1)) then
declare
- V1 : Uint := Expr_Value (Expr1);
- V2 : Uint := Expr_Value (Expr2);
+ V1 : constant Uint := Expr_Value (Expr1);
+ V2 : constant Uint := Expr_Value (Expr2);
begin
Check_Mismatch (V1 /= V2);
end;
elsif Is_Real_Type (Etype (E1)) then
-
declare
- V1 : Ureal := Expr_Value_R (Expr1);
- V2 : Ureal := Expr_Value_R (Expr2);
+ V1 : constant Ureal := Expr_Value_R (Expr1);
+ V2 : constant Ureal := Expr_Value_R (Expr2);
begin
Check_Mismatch (V1 /= V2);
end;
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));
-- Check_Forward_Instantiation --
---------------------------------
- procedure Check_Forward_Instantiation (N : Node_Id; Decl : Node_Id) is
+ procedure Check_Forward_Instantiation (Decl : Node_Id) is
S : Entity_Id;
Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
Set_Is_Hidden (E, False);
end if;
+ -- If this is a subprogram instance (in a wrapper package) the
+ -- actual is fully visible.
+
+ elsif Is_Wrapper_Package (Instance) then
+ Set_Is_Hidden (E, False);
+
else
Set_Is_Hidden (E, not Is_Formal_Box);
end if;
Next_Entity (E);
end loop;
-
end Check_Generic_Actuals;
------------------------------
(Scop : Entity_Id;
Id : Node_Id)
return Entity_Id;
- -- Search generic parent for possible child unit.
+ -- 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
- -- by a simple name. Examine enclosing scopes to locate a possible
- -- parent instantiation.
+ -- by a simple name, or an abbreviated expanded name. Examine enclosing
+ -- scopes to locate a possible parent instantiation.
+
+ ------------------------
+ -- Find_Generic_Child --
+ ------------------------
function Find_Generic_Child
(Scop : Entity_Id;
end if;
end Find_Generic_Child;
+ ---------------------------
+ -- In_Enclosing_Instance --
+ ---------------------------
+
function In_Enclosing_Instance return Boolean is
Enclosing_Instance : Node_Id;
+ Instance_Decl : Node_Id;
begin
Enclosing_Instance := Current_Scope;
while Present (Enclosing_Instance) loop
- exit when Ekind (Enclosing_Instance) = E_Package
- and then Nkind (Parent (Enclosing_Instance)) =
- N_Package_Specification
+ Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
+
+ if Ekind (Enclosing_Instance) = E_Package
+ and then Is_Generic_Instance (Enclosing_Instance)
and then Present
- (Generic_Parent (Parent (Enclosing_Instance)));
+ (Generic_Parent (Specification (Instance_Decl)))
+ then
+ -- Check whether the generic we are looking for is a child
+ -- of this instance.
+
+ E := Find_Generic_Child
+ (Generic_Parent (Specification (Instance_Decl)), Gen_Id);
+ exit when Present (E);
+
+ else
+ E := Empty;
+ end if;
Enclosing_Instance := Scope (Enclosing_Instance);
end loop;
- if Present (Enclosing_Instance) then
- E := Find_Generic_Child
- (Generic_Parent (Parent (Enclosing_Instance)), Gen_Id);
- else
+ if No (E) then
+
+ -- Not a child unit
+
+ Analyze (Gen_Id);
return False;
- end if;
- if Present (E) then
+ else
Rewrite (Gen_Id,
Make_Expanded_Name (Loc,
Chars => Chars (E),
Set_Etype (Gen_Id, Etype (E));
Parent_Installed := False; -- Already in scope.
return True;
- else
- Analyze (Gen_Id);
- return False;
end if;
end In_Enclosing_Instance;
elsif Ekind (Inst_Par) = E_Generic_Package
and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
then
-
-- A formal package may be a real child package, and not the
-- implicit instance within a parent. In this case the child is
-- not visible and has to be retrieved explicitly as well.
-- A common mistake is to replicate the naming scheme of
-- a hierarchy by instantiating a generic child directly,
-- rather than the implicit child in a parent instance:
- --
+
-- generic .. package Gpar is ..
-- generic .. package Gpar.Child is ..
-- package Par is new Gpar ();
-- with Gpar.Child;
-- package Par.Child is new Gpar.Child ();
-- rather than Par.Child
- --
+
-- In this case the instantiation is within Par, which is
-- an instance, but Gpar does not denote Par because we are
-- not IN the instance of Gpar, so this is illegal. The test
end if;
if not In_Open_Scopes (Inst_Par)
- and then Nkind (Parent (Gen_Id))
- not in N_Generic_Renaming_Declaration
+ and then Nkind (Parent (Gen_Id)) not in
+ N_Generic_Renaming_Declaration
then
Install_Parent (Inst_Par);
Parent_Installed := True;
Analyze (Gen_Id);
if Is_Child_Unit (Entity (Gen_Id))
- and then Nkind (Parent (Gen_Id))
- not in N_Generic_Renaming_Declaration
+ and then
+ Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
and then not In_Open_Scopes (Inst_Par)
then
Install_Parent (Inst_Par);
end if;
elsif In_Enclosing_Instance then
- -- The child unit is found in some enclosing scope.
+
+ -- The child unit is found in some enclosing scope
+
null;
else
Gen_Unit : Entity_Id;
Act_Decl_Id : Entity_Id)
is
- Gen_Id : Node_Id := Name (N);
+ Gen_Id : constant Node_Id := Name (N);
begin
if Is_Child_Unit (Gen_Unit)
elsif Is_Access_Type (T)
and then Is_Private_Type (Designated_Type (T))
+ and then not Has_Private_View (N)
and then Present (Full_View (Designated_Type (T)))
then
Switch_View (Designated_Type (T));
-- Finally, a non-private subtype may have a private base type,
-- which must be exchanged for consistency. This can happen when
- -- instantiating a package body, when the scope stack is empty but
- -- in fact the subtype and the base type are declared in an enclosing
- -- scope.
+ -- instantiating a package body, when the scope stack is empty
+ -- but in fact the subtype and the base type are declared in an
+ -- enclosing scope.
elsif not Is_Private_Type (T)
and then not Has_Private_View (N)
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
+ -- of a child unit. The entity of such an identifier must be kept
+ -- (for ASIS use) even though as the name of an enclosing generic
+ -- it would otherwise not be preserved in the generic tree.
+
-----------------------
-- Copy_Descendants --
-----------------------
end if;
end Copy_Generic_List;
+ ---------------------------
+ -- In_Defining_Unit_Name --
+ ---------------------------
+
+ function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is
+ begin
+ return Present (Parent (Nam))
+ and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
+ or else
+ (Nkind (Parent (Nam)) = N_Expanded_Name
+ and then In_Defining_Unit_Name (Parent (Nam))));
+ end In_Defining_Unit_Name;
+
-- Start of processing for Copy_Generic_Node
begin
-- Special casing for identifiers and other entity names and operators
- elsif (Nkind (New_N) = N_Identifier
+ elsif Nkind (New_N) = N_Identifier
or else Nkind (New_N) = N_Character_Literal
or else Nkind (New_N) = N_Expanded_Name
or else Nkind (New_N) = N_Operator_Symbol
- or else Nkind (New_N) in N_Op)
+ or else Nkind (New_N) in N_Op
then
if not Instantiating then
if No (Current_Instantiated_Parent.Gen_Id) then
if No (Ent)
or else Nkind (Ent) /= N_Defining_Identifier
- or else Nkind (Parent (N)) /= N_Defining_Program_Unit_Name
+ or else not In_Defining_Unit_Name (N)
then
Set_Associated_Node (New_N, Empty);
end if;
else
-- If the associated node is still defined, the entity in
-- it is global, and must be copied to the instance.
+ -- If this copy is being made for a body to inline, it is
+ -- applied to an instantiated tree, and the entity is already
+ -- present and must be also preserved.
- if Present (Get_Associated_Node (N)) then
- if Nkind (Get_Associated_Node (N)) = Nkind (N) then
- Set_Entity (New_N, Entity (Get_Associated_Node (N)));
- Check_Private_View (N);
+ declare
+ Assoc : constant Node_Id := Get_Associated_Node (N);
+ begin
+ if Present (Assoc) then
+ if Nkind (Assoc) = Nkind (N) then
+ Set_Entity (New_N, Entity (Assoc));
+ Check_Private_View (N);
+
+ elsif Nkind (Assoc) = N_Function_Call then
+ Set_Entity (New_N, Entity (Name (Assoc)));
+
+ elsif (Nkind (Assoc) = N_Defining_Identifier
+ or else Nkind (Assoc) = N_Defining_Character_Literal
+ or else Nkind (Assoc) = N_Defining_Operator_Symbol)
+ and then Expander_Active
+ then
+ -- Inlining case: we are copying a tree that contains
+ -- global entities, which are preserved in the copy
+ -- to be used for subsequent inlining.
- elsif Nkind (Get_Associated_Node (N)) = N_Function_Call then
- Set_Entity (New_N, Entity (Name (Get_Associated_Node (N))));
+ null;
- else
- Set_Entity (New_N, Empty);
+ else
+ Set_Entity (New_N, Empty);
+ end if;
end if;
- end if;
+ end;
end if;
-- For expanded name, we must copy the Prefix and Selector_Name
if Nkind (N) = N_Expanded_Name then
-
Set_Prefix
(New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
-- For operators, we must copy the right operand
elsif Nkind (N) in N_Op then
-
Set_Right_Opnd (New_N,
Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
Subunit := Cunit (Unum);
+ if Nkind (Unit (Subunit)) /= N_Subunit then
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_N
+ ("expected SEPARATE subunit to complete stub at#,"
+ & " found child unit", Subunit);
+ goto Subunit_Not_Found;
+ end if;
+
-- We must create a generic copy of the subunit, in order
-- to perform semantic analysis on it, and we must replace
-- the stub in the original generic unit with the subunit,
Set_Proper_Body (Unit (Subunit), New_Body);
Set_Library_Unit (New_N, Subunit);
Inherit_Context (Unit (Subunit), N);
-
end;
-- If we are instantiating, this must be an error case, since
if Present (Get_Associated_Node (N))
and then Nkind (Get_Associated_Node (N)) = Nkind (N)
then
- -- In the generic the aggregate has some composite type.
- -- If at the point of instantiation the type has a private
- -- view, install the full view (and that of its ancestors,
- -- if any).
+ -- In the generic the aggregate has some composite type. If at
+ -- the point of instantiation the type has a private view,
+ -- install the full view (and that of its ancestors, if any).
declare
T : Entity_Id := (Etype (Get_Associated_Node (New_N)));
elsif Nkind (N) = N_Allocator
and then Nkind (Expression (N)) = N_Qualified_Expression
+ and then Is_Entity_Name (Subtype_Mark (Expression (N)))
and then Instantiating
then
declare
- T : Node_Id := Get_Associated_Node (Subtype_Mark (Expression (N)));
- Acc_T : Entity_Id;
+ T : constant Node_Id :=
+ Get_Associated_Node (Subtype_Mark (Expression (N)));
+ Acc_T : Entity_Id;
begin
if Present (T) then
-- adjusted using this new source instantiation entry.
elsif Nkind (N) in N_Proper_Body then
-
declare
Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
begin
if Instantiating and then Was_Originally_Stub (N) then
Create_Instantiation_Source
- (Instantiation_Node, Defining_Entity (N), S_Adjustment);
+ (Instantiation_Node,
+ Defining_Entity (N),
+ False,
+ S_Adjustment);
end if;
-- Now copy the fields of the proper body, using the new
end if;
end;
- -- For the remaining nodes, copy recursively their descendants.
+ elsif Nkind (N) = N_Integer_Literal
+ or else Nkind (N) = N_Real_Literal
+ then
+ -- No descendant fields need traversing
+
+ null;
+
+ -- For the remaining nodes, copy recursively their descendants
else
Copy_Descendants;
function Denotes_Formal_Package (Pack : Entity_Id) return Boolean is
Par : constant Entity_Id := Current_Instantiated_Parent.Act_Id;
- Scop : Entity_Id := Scope (Pack);
+ Scop : constant Entity_Id := Scope (Pack);
E : Entity_Id;
begin
if Ekind (Scop) = E_Generic_Package
- or else Nkind (Unit_Declaration_Node (Scop))
- = N_Generic_Subprogram_Declaration
+ or else Nkind (Unit_Declaration_Node (Scop)) =
+ N_Generic_Subprogram_Declaration
then
return True;
E := First_Entity (Par);
while Present (E) loop
-
if Ekind (E) /= E_Package
or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
then
Pack_Id : Entity_Id)
is
F_Node : Node_Id;
- Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node));
+ Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Par : constant Entity_Id := Scope (Gen_Unit);
Enc_G : Entity_Id;
Enc_I : Node_Id;
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)
end loop;
end Find_Depth;
+ -- Start of procesing for Earlier
+
begin
Find_Depth (P1, D1);
Find_Depth (P2, D2);
and then
In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
then
- Insert_After (Freeze_Node (Par), F_Node);
+ 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.
+
+ Insert_After_Last_Decl (Inst_Node, F_Node);
+
+ else
+ Insert_After (Freeze_Node (Par), F_Node);
+ end if;
-- The body enclosing the instance should be frozen after the body
-- that includes the generic, because the body of the instance may
and then
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
Insert_After_Last_Decl (Inst_Node, F_Node);
else
-
-- If none of the above, insert freeze node at the end of the
-- current declarative part.
---------------------
function Get_Instance_Of (A : Entity_Id) return Entity_Id is
- Res : Assoc_Ptr := Generic_Renamings_HTable.Get (A);
+ Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A);
+
begin
if Res /= Assoc_Null then
return Generic_Renamings.Table (Res).Act_Id;
-- If the instantiation is a compilation unit that does not need a
-- body then the instantiation node has been rewritten as a package
-- declaration for the instance, and we return the original node.
+
-- If it is a compilation unit and the instance node has not been
- -- rewritten, then it is still the unit of the compilation.
+ -- rewritten, then it is still the unit of the compilation. Finally,
+ -- if a body is present, this is a parent of the main unit whose body
+ -- has been compiled for inlining purposes, and the instantiation node
+ -- has been rewritten with the instance body.
+
-- Otherwise the instantiation node appears after the declaration.
-- If the entity is a formal package, the declaration may have been
-- rewritten as a generic declaration (in the case of a formal with a
-- is found with a forward search.
if Nkind (Parent (Decl)) = N_Compilation_Unit then
+ if Nkind (Decl) = N_Package_Declaration
+ and then Present (Corresponding_Body (Decl))
+ then
+ Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
+ end if;
+
if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
return Original_Node (Decl);
else
end Hide_Current_Scope;
+ --------------
+ -- Init_Env --
+ --------------
+
+ procedure Init_Env is
+ Saved : Instance_Env;
+
+ begin
+ 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;
+ Instance_Envs.Increment_Last;
+ Instance_Envs.Table (Instance_Envs.Last) := Saved;
+
+ Exchanged_Views := New_Elmt_List;
+ Hidden_Entities := New_Elmt_List;
+
+ -- Make dummy entry for Instantiated parent. If generic unit is
+ -- legal, this is set properly in Set_Instance_Env.
+
+ Current_Instantiated_Parent :=
+ (Current_Scope, Current_Scope, Assoc_Null);
+ end Init_Env;
+
------------------------------
-- In_Same_Declarative_Part --
------------------------------
Inst : Node_Id)
return Boolean
is
- Decls : Node_Id := Parent (F_Node);
+ Decls : constant Node_Id := Parent (F_Node);
Nod : Node_Id := Parent (Inst);
begin
end if;
end Inherit_Context;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Generic_Renamings.Init;
+ Instance_Envs.Init;
+ Generic_Flags.Init;
+ Generic_Renamings_HTable.Reset;
+ Circularity_Detected := False;
+ Exchanged_Views := No_Elist;
+ Hidden_Entities := No_Elist;
+ end Initialize;
+
----------------------------
-- Insert_After_Last_Decl --
----------------------------
procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
- L : List_Id := List_Containing (N);
- P : Node_Id := Parent (L);
+ L : List_Id := List_Containing (N);
+ P : constant Node_Id := Parent (L);
begin
if not Is_List_Member (F_Node) then
Gen_Body : Node_Id;
Gen_Decl : Node_Id)
is
- Act_Id : Entity_Id := Corresponding_Spec (Act_Body);
- Act_Unit : constant Node_Id :=
- Unit (Cunit (Get_Source_Unit (N)));
- F_Node : Node_Id;
- Gen_Id : Entity_Id := Corresponding_Spec (Gen_Body);
+ Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
+ Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
+ Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
+ Par : constant Entity_Id := Scope (Gen_Id);
Gen_Unit : constant Node_Id :=
Unit (Cunit (Get_Source_Unit (Gen_Decl)));
Orig_Body : Node_Id := Gen_Body;
- Par : constant Entity_Id := Scope (Gen_Id);
+ F_Node : Node_Id;
Body_Unit : Node_Id;
Must_Delay : Boolean;
then
declare
- Enclosing : Entity_Id := Corresponding_Spec (Parent (N));
+ Enclosing : constant Entity_Id :=
+ Corresponding_Spec (Parent (N));
begin
Insert_After_Last_Decl (N, F_Node);
--------------------
procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
- S : Entity_Id := Current_Scope;
+ Ancestors : constant Elist_Id := New_Elmt_List;
+ S : constant Entity_Id := Current_Scope;
Inst_Par : Entity_Id;
First_Par : Entity_Id;
Inst_Node : Node_Id;
Gen_Par : Entity_Id;
First_Gen : Entity_Id;
- Ancestors : Elist_Id := New_Elmt_List;
Elmt : Elmt_Id;
procedure Install_Formal_Packages (Par : Entity_Id);
while Present (Gen_Par)
and then Is_Child_Unit (Gen_Par)
loop
- -- Load grandparent instance as well.
+ -- Load grandparent instance as well
Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
Prepend_Elmt (Inst_Par, Ancestors);
else
- -- Parent is not the name of an instantiation.
+ -- Parent is not the name of an instantiation
Install_Noninstance_Specs (Inst_Par);
end if;
else
- -- Previous error.
+ -- Previous error
exit;
end if;
Nod : Node_Id;
Parent_Spec : Node_Id;
+ procedure Find_Matching_Actual
+ (F : Node_Id;
+ Act : in out Entity_Id);
+ -- We need to associate each formal entity in the formal package
+ -- with the corresponding entity in the actual package. The actual
+ -- package has been analyzed and possibly expanded, and as a result
+ -- there is no one-to-one correspondence between the two lists (for
+ -- example, the actual may include subtypes, itypes, and inherited
+ -- primitive operations, interspersed among the renaming declarations
+ -- for the actuals) . We retrieve the corresponding actual by name
+ -- because each actual has the same name as the formal, and they do
+ -- appear in the same order.
+
function Formal_Entity
(F : Node_Id;
Act_Ent : Entity_Id)
-- parameters. This function is called recursively for arbitrary
-- levels of formal packages.
+ function Is_Instance_Of
+ (Act_Spec : Entity_Id;
+ 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
+ -- ultimate ancestor is the same by examining names and scopes.
+
procedure Map_Entities (Form : Entity_Id; Act : Entity_Id);
-- Within the generic part, entities in the formal package are
-- visible. To validate subsequent type declarations, indicate
-- that the entities in P2 are mapped into those of P3. The mapping of
-- entities has to be done recursively for nested packages.
+ --------------------------
+ -- Find_Matching_Actual --
+ --------------------------
+
+ procedure Find_Matching_Actual
+ (F : Node_Id;
+ Act : in out Entity_Id)
+ is
+ Formal_Ent : Entity_Id;
+
+ begin
+ case Nkind (Original_Node (F)) is
+ when N_Formal_Object_Declaration |
+ N_Formal_Type_Declaration =>
+ Formal_Ent := Defining_Identifier (F);
+
+ while Chars (Act) /= Chars (Formal_Ent) loop
+ Next_Entity (Act);
+ end loop;
+
+ when N_Formal_Subprogram_Declaration |
+ N_Formal_Package_Declaration |
+ N_Package_Declaration |
+ N_Generic_Package_Declaration =>
+ Formal_Ent := Defining_Entity (F);
+
+ while Chars (Act) /= Chars (Formal_Ent) loop
+ Next_Entity (Act);
+ end loop;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Find_Matching_Actual;
+
-------------------
-- Formal_Entity --
-------------------
return Entity_Id
is
Orig_Node : Node_Id := F;
+ Act_Pkg : Entity_Id;
begin
- case Nkind (F) is
- when N_Formal_Object_Declaration =>
+ case Nkind (Original_Node (F)) is
+ when N_Formal_Object_Declaration =>
return Defining_Identifier (F);
- when N_Formal_Type_Declaration =>
+ when N_Formal_Type_Declaration =>
return Defining_Identifier (F);
when N_Formal_Subprogram_Declaration =>
return Defining_Unit_Name (Specification (F));
+ when N_Package_Declaration =>
+ return Defining_Unit_Name (Specification (F));
+
when N_Formal_Package_Declaration |
- N_Generic_Package_Declaration =>
+ N_Generic_Package_Declaration =>
if Nkind (F) = N_Generic_Package_Declaration then
Orig_Node := Original_Node (F);
end if;
+ Act_Pkg := Act_Ent;
+
+ -- Find matching actual package, skipping over itypes and
+ -- other entities generated when analyzing the formal. We
+ -- know that if the instantiation is legal then there is
+ -- a matching package for the formal.
+
+ while Ekind (Act_Pkg) /= E_Package loop
+ Act_Pkg := Next_Entity (Act_Pkg);
+ end loop;
+
declare
- Actual_Ent : Entity_Id := First_Entity (Act_Ent);
+ Actual_Ent : Entity_Id := First_Entity (Act_Pkg);
Formal_Node : Node_Id;
Formal_Ent : Entity_Id;
- Gen_Decl : Node_Id :=
+ Gen_Decl : constant Node_Id :=
Unit_Declaration_Node
(Entity (Name (Orig_Node)));
- Formals : List_Id :=
- Generic_Formal_Declarations (Gen_Decl);
+
+ Formals : constant List_Id :=
+ Generic_Formal_Declarations (Gen_Decl);
begin
if Present (Formals) then
Formal_Node := Empty;
end if;
- -- As for the loop further below, this loop is making
- -- a probably invalid assumption about the correspondence
- -- between formals and actuals and eventually needs to
- -- corrected to account for cases where the formals are
- -- not synchronized and in one-to-one correspondence
- -- with actuals. ???
-
- -- What is certain is that for a legal program the
- -- presence of actual entities guarantees the existing
- -- of formal ones.
-
while Present (Actual_Ent)
and then Present (Formal_Node)
and then Actual_Ent /= First_Private_Entity (Act_Ent)
end case;
end Formal_Entity;
+ --------------------
+ -- Is_Instance_Of --
+ --------------------
+
+ function Is_Instance_Of
+ (Act_Spec : Entity_Id;
+ Gen_Anc : Entity_Id)
+ return Boolean
+ is
+ Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
+
+ begin
+ if No (Gen_Par) then
+ return False;
+
+ -- Simplest case: the generic parent of the actual is the formal.
+
+ elsif Gen_Par = Gen_Anc then
+ return True;
+
+ elsif Chars (Gen_Par) /= Chars (Gen_Anc) then
+ return False;
+
+ -- The actual may be obtained through several instantiations. Its
+ -- scope must itself be an instance of a generic declared in the
+ -- same scope as the formal. Any other case is detected above.
+
+ elsif not Is_Generic_Instance (Scope (Gen_Par)) then
+ return False;
+
+ else
+ return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc);
+ end if;
+ end Is_Instance_Of;
+
------------------
-- Map_Entities --
------------------
begin
Set_Instance_Of (Form, Act);
+ -- Traverse formal and actual package to map the corresponding
+ -- entities. We skip over internal entities that may be generated
+ -- during semantic analysis, and find the matching entities by
+ -- name, given that they must appear in the same order.
+
E1 := First_Entity (Form);
E2 := First_Entity (Act);
while Present (E1)
loop
if not Is_Internal (E1)
and then not Is_Class_Wide_Type (E1)
+ and then Present (Parent (E1))
then
-
while Present (E2)
and then Chars (E2) /= Chars (E1)
loop
Abandon_Instantiation (Actual);
elsif
- Generic_Parent (Parent_Spec) /= Get_Instance_Of (Gen_Parent)
+ Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent))
then
+ null;
+
+ else
Error_Msg_NE
("actual parameter must be instance of&", Actual, Gen_Parent);
Abandon_Instantiation (Actual);
-- actuals into the renaming map. This is necessary to properly
-- handle checking of actual parameter associations for later
-- formals that depend on actuals declared in the formal package.
- --
- -- This processing needs to be reviewed at some point because
- -- it is probably not entirely correct as written. For example
- -- there may not be a strict one-to-one correspondence between
- -- actuals and formals and this loop is currently assuming that
- -- there is. ???
if Box_Present (Formal) then
declare
- Actual_Ent : Entity_Id := First_Entity (Actual_Pack);
- Formal_Node : Node_Id := Empty;
+ Gen_Decl : constant Node_Id :=
+ Unit_Declaration_Node (Gen_Parent);
+ Formals : constant List_Id :=
+ Generic_Formal_Declarations (Gen_Decl);
+ Actual_Ent : Entity_Id;
+ Formal_Node : Node_Id;
Formal_Ent : Entity_Id;
- Gen_Decl : Node_Id := Unit_Declaration_Node (Gen_Parent);
- Formals : List_Id := Generic_Formal_Declarations (Gen_Decl);
begin
if Present (Formals) then
Formal_Node := First_Non_Pragma (Formals);
+ else
+ Formal_Node := Empty;
end if;
+ Actual_Ent := First_Entity (Actual_Pack);
+
while Present (Actual_Ent)
and then Actual_Ent /= First_Private_Entity (Actual_Pack)
loop
Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
if Present (Formal_Ent) then
+ Find_Matching_Actual (Formal_Node, Actual_Ent);
Set_Instance_Of (Formal_Ent, Actual_Ent);
end if;
Next_Non_Pragma (Formal_Node);
+
+ else
+ -- No further formals to match, but the generic
+ -- part may contain inherited operation that are
+ -- not hidden in the enclosing instance.
+
+ Next_Entity (Actual_Ent);
end if;
- Next_Entity (Actual_Ent);
end loop;
end;
return Decls;
end if;
-
end Instantiate_Formal_Package;
-----------------------------------
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id)
- return Node_Id
+ return Node_Id
is
Loc : Source_Ptr := Sloc (Instantiation_Node);
Formal_Sub : constant Entity_Id :=
-----------------------------
procedure Valid_Actual_Subprogram (Act : Node_Id) is
+ Act_E : Entity_Id := Empty;
+
begin
- if not Is_Entity_Name (Act)
- and then Nkind (Act) /= N_Operator_Symbol
- and then Nkind (Act) /= N_Attribute_Reference
- and then Nkind (Act) /= N_Selected_Component
- and then Nkind (Act) /= N_Indexed_Component
- and then Nkind (Act) /= N_Character_Literal
- and then Nkind (Act) /= N_Explicit_Dereference
+ if Is_Entity_Name (Act) then
+ Act_E := Entity (Act);
+ elsif Nkind (Act) = N_Selected_Component
+ and then Is_Entity_Name (Selector_Name (Act))
then
- if Etype (Act) /= Any_Type then
- Error_Msg_NE
- ("Expect subprogram name to instantiate &",
- Instantiation_Node, Formal_Sub);
- end if;
-
- -- In any case, instantiation cannot continue.
+ Act_E := Entity (Selector_Name (Act));
+ end if;
- Abandon_Instantiation (Instantiation_Node);
+ if (Present (Act_E) and then Is_Overloadable (Act_E))
+ or else Nkind (Act) = N_Attribute_Reference
+ or else Nkind (Act) = N_Indexed_Component
+ or else Nkind (Act) = N_Character_Literal
+ or else Nkind (Act) = N_Explicit_Dereference
+ then
+ return;
end if;
+
+ Error_Msg_NE
+ ("expect subprogram or entry name in instantiation of&",
+ Instantiation_Node, Formal_Sub);
+ Abandon_Instantiation (Instantiation_Node);
+
end Valid_Actual_Subprogram;
-- Start of processing for Instantiate_Formal_Subprogram
Nam := Actual;
elsif Present (Default_Name (Formal)) then
-
if Nkind (Default_Name (Formal)) /= N_Attribute_Reference
and then Nkind (Default_Name (Formal)) /= N_Selected_Component
and then Nkind (Default_Name (Formal)) /= N_Indexed_Component
end if;
else
+ Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
+ Error_Msg_NE
+ ("missing actual&", Instantiation_Node, Formal_Sub);
Error_Msg_NE
- ("missing actual for instantiation of &",
- Instantiation_Node, Formal_Sub);
+ ("\in instantiation of & declared#",
+ Instantiation_Node, Scope (Analyzed_S));
Abandon_Instantiation (Instantiation_Node);
end if;
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 declaration.
+ -- spec of the node to point to the formal subprogram entity.
- Set_Corresponding_Spec (Decl_Node, Analyzed_Formal);
+ Set_Corresponding_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.
Insert_Before (Instantiation_Node, Decl_Node);
Analyze (Decl_Node);
- -- Now create renaming within the instance.
+ -- Now create renaming within the instance
Decl_Node :=
Make_Subprogram_Renaming_Declaration (Loc,
Act_Assoc : constant Node_Id := Parent (Actual);
Orig_Ftyp : constant Entity_Id :=
Etype (Defining_Identifier (Analyzed_Formal));
+ List : constant List_Id := New_List;
Ftyp : Entity_Id;
Decl_Node : Node_Id;
Subt_Decl : Node_Id := Empty;
- List : List_Id := New_List;
begin
+ -- 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
Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
end if;
if No (Actual) then
Error_Msg_NE
- ("missing actual for instantiation of &",
+ ("missing actual&",
Instantiation_Node, Formal_Id);
+ Error_Msg_NE
+ ("\in instantiation of & declared#",
+ Instantiation_Node,
+ Scope (Defining_Identifier (Analyzed_Formal)));
Abandon_Instantiation (Instantiation_Node);
end if;
end if;
Append (Decl_Node, List);
- Analyze (Actual);
+
+ -- No need to repeat (pre-)analysis of some expression nodes
+ -- already handled in Pre_Analyze_Actuals.
+
+ if Nkind (Actual) /= N_Allocator then
+ Analyze (Actual);
+ end if;
declare
- Typ : Entity_Id
- := Get_Instance_Of
- (Etype (Defining_Identifier (Analyzed_Formal)));
+ Typ : constant Entity_Id :=
+ Get_Instance_Of
+ (Etype (Defining_Identifier (Analyzed_Formal)));
+
begin
Freeze_Before (Instantiation_Node, Typ);
else
Error_Msg_NE
- ("missing actual for instantiation of &",
- Instantiation_Node, Formal_Id);
- Abandon_Instantiation (Instantiation_Node);
+ ("missing actual&",
+ Instantiation_Node, Formal_Id);
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node,
+ Scope (Defining_Identifier (Analyzed_Formal)));
+
+ if Is_Scalar_Type
+ (Etype (Defining_Identifier (Analyzed_Formal)))
+ then
+ -- Create dummy constant declaration so that instance can
+ -- be analyzed, to minimize cascaded visibility errors.
+
+ Decl_Node :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => New_Copy (Formal_Id),
+ Constant_Present => True,
+ Object_Definition => New_Copy (Type_Id),
+ Expression =>
+ Make_Attribute_Reference (Sloc (Formal_Id),
+ Attribute_Name => Name_First,
+ Prefix => New_Copy (Type_Id)));
+
+ Append (Decl_Node, List);
+
+ else
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
end if;
end if;
------------------------------
procedure Instantiate_Package_Body
- (Body_Info : Pending_Body_Info)
+ (Body_Info : Pending_Body_Info;
+ Inlined_Body : Boolean := False)
is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
Loc : constant Source_Ptr := Sloc (Inst_Node);
Gen_Id : constant Node_Id := Name (Inst_Node);
- Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node));
+ Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
Act_Spec : constant Node_Id := Specification (Act_Decl);
Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec);
Act_Body_Id : Entity_Id;
Parent_Installed : Boolean := False;
- Save_Style_Check : Boolean := Style_Check;
+ Save_Style_Check : constant Boolean := Style_Check;
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
+
+ -- The instance body may already have been processed, as the parent
+ -- of another instance that is inlined. (Load_Parent_Of_Generic).
+
+ if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then
+ return;
+ end if;
+
Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
if No (Gen_Body_Id) then
Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
Create_Instantiation_Source
- (Inst_Node, Gen_Body_Id, S_Adjustment);
+ (Inst_Node, Gen_Body_Id, False, S_Adjustment);
Act_Body :=
Copy_Generic_Node
(Original_Node (Gen_Body), Empty, Instantiating => True);
- -- Build new name (possibly qualified) for body declaration.
+ -- Build new name (possibly qualified) for body declaration
Act_Body_Id := New_Copy (Act_Decl_Id);
if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
+ -- Replace instance node with body of instance, and create
+ -- new node for corresponding instance declaration.
+
+ Build_Instance_Compilation_Unit_Nodes
+ (Inst_Node, Act_Body, Act_Decl);
+ Analyze (Inst_Node);
+
if Parent (Inst_Node) = Cunit (Main_Unit) then
- Build_Instance_Compilation_Unit_Nodes
- (Inst_Node, Act_Body, Act_Decl);
- Analyze (Inst_Node);
-- If the instance is a child unit itself, then set the
-- scope of the expanded body to be the parent of the
Set_Scope
(Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
end if;
-
- else
- Set_Parent (Act_Body, Parent (Inst_Node));
- Analyze (Act_Body);
end if;
-- Case where instantiation is not a library unit
Inherit_Context (Gen_Body, Inst_Node);
end if;
+ -- Remove the parent instances if they have been placed on the
+ -- scope stack to compile the body.
+
+ if Parent_Installed then
+ Remove_Parent (In_Body => True);
+ end if;
+
Restore_Private_Views (Act_Decl_Id);
+
+ -- Remove the current unit from visibility if this is an instance
+ -- that is not elaborated on the fly for inlining purposes.
+
+ if not Inlined_Body then
+ Set_Is_Immediately_Visible (Act_Decl_Id, False);
+ end if;
+
Restore_Env;
Style_Check := Save_Style_Check;
-- (since a common reason for missing the body is that it had errors).
elsif Unit_Requires_Body (Gen_Unit) then
- if Errors_Detected = 0 then
+ if Serious_Errors_Detected = 0 then
Error_Msg_NE
("cannot find body of generic package &", Inst_Node, Gen_Unit);
Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
Rewrite (Inst_Node, Act_Decl);
+ -- Generate elaboration entity, in case spec has elaboration
+ -- code. This cannot be done when the instance is analyzed,
+ -- because it is not known yet whether the body exists.
+
+ Set_Elaboration_Entity_Required (Act_Decl_Id, False);
+ Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id);
+
-- If the instantiation is not a library unit, then append the
-- declaration to the list of implicitly generated entities.
-- unless it is already a list member which means that it was
end if;
Expander_Mode_Restore;
-
- -- Remove the parent instances if they have been placed on the
- -- scope stack to compile the body.
-
- if Parent_Installed then
- Remove_Parent (In_Body => True);
- end if;
end Instantiate_Package_Body;
---------------------------------
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
Loc : constant Source_Ptr := Sloc (Inst_Node);
-
- Decls : List_Id;
Gen_Id : constant Node_Id := Name (Inst_Node);
- Gen_Unit : constant Entity_Id := Entity (Name (Inst_Node));
+ Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
Anon_Id : constant Entity_Id :=
Defining_Unit_Name (Specification (Act_Decl));
+ Pack_Id : constant Entity_Id :=
+ Defining_Unit_Name (Parent (Act_Decl));
+ Decls : List_Id;
Gen_Body : Node_Id;
Gen_Body_Id : Node_Id;
Act_Body : Node_Id;
Act_Body_Id : Entity_Id;
- Pack_Id : Entity_Id := Defining_Unit_Name (Parent (Act_Decl));
Pack_Body : Node_Id;
Prev_Formal : Entity_Id;
+ Ret_Expr : Node_Id;
Unit_Renaming : Node_Id;
Parent_Installed : Boolean := False;
- Save_Style_Check : Boolean := Style_Check;
+ Save_Style_Check : constant Boolean := Style_Check;
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
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;
Save_Env (Gen_Unit, Anon_Id);
Style_Check := False;
Current_Sem_Unit := Body_Info.Current_Sem_Unit;
- Create_Instantiation_Source (Inst_Node, Gen_Body_Id, S_Adjustment);
+ Create_Instantiation_Source
+ (Inst_Node,
+ Gen_Body_Id,
+ False,
+ S_Adjustment);
Act_Body :=
Copy_Generic_Node
-- of the corresponding compilation.
if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
-
if Parent (Inst_Node) = Cunit (Main_Unit) then
Set_Unit (Parent (Inst_Node), Inst_Node);
Build_Instance_Compilation_Unit_Nodes
-- raise program error if executed. We generate a subprogram body for
-- this purpose. See DEC ac30vso.
- elsif Errors_Detected = 0
+ elsif Serious_Errors_Detected = 0
and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
then
if Ekind (Anon_Id) = E_Procedure then
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements =>
- New_List (Make_Raise_Program_Error (Loc))));
+ New_List (
+ Make_Raise_Program_Error (Loc,
+ Reason =>
+ PE_Access_Before_Elaboration))));
+
else
+ Ret_Expr :=
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Access_Before_Elaboration);
+
+ Set_Etype (Ret_Expr, (Etype (Anon_Id)));
+ Set_Analyzed (Ret_Expr);
+
Act_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Return_Statement (Loc,
- Expression => Make_Raise_Program_Error (Loc)))));
+ Statements =>
+ New_List (Make_Return_Statement (Loc, Ret_Expr))));
end if;
Pack_Body := Make_Package_Body (Loc,
function Instantiate_Type
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
+ Analyzed_Formal : Node_Id;
+ Actual_Decls : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Actual);
Gen_T : constant Entity_Id := Defining_Identifier (Formal);
A_Gen_T : constant Entity_Id := Defining_Identifier (Analyzed_Formal);
- Ancestor : Entity_Id;
+ Ancestor : Entity_Id := Empty;
Def : constant Node_Id := Formal_Type_Definition (Formal);
Act_T : Entity_Id;
Decl_Node : Node_Id;
-----------------------------------
procedure Validate_Access_Type_Instance is
- Desig_Type : Entity_Id :=
- Find_Actual_Type (Designated_Type (A_Gen_T), Scope (A_Gen_T));
+ Desig_Type : constant Entity_Id :=
+ Find_Actual_Type
+ (Designated_Type (A_Gen_T), Scope (A_Gen_T));
begin
if not Is_Access_Type (Act_T) then
-- a previous formal type, then it is local to the generic
-- and absent from the analyzed generic definition. In that
-- case the ancestor is the instance of the formal (which must
- -- have been instantiated previously). Otherwise, the analyzed
+ -- have been instantiated previously), unless the ancestor is
+ -- itself a formal derived type. In this latter case (which is the
+ -- subject of Corrigendum 8652/0038 (AI-202) the ancestor of the
+ -- formals is the ancestor of its parent. Otherwise, the analyzed
-- generic carries the parent type. If the parent type is defined
-- in a previous formal package, then the scope of that formal
-- package is that of the generic type itself, and it has already
-- been mapped into the corresponding type in the actual package.
- -- Common case: parent type defined outside of the generic.
+ -- Common case: parent type defined outside of the generic
if Is_Entity_Name (Subtype_Mark (Def))
and then Present (Entity (Subtype_Mark (Def)))
then
Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
- -- Check whether parent is defined in a previous formal package.
+ -- Check whether parent is defined in a previous formal package
elsif
Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
Ancestor :=
Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
- elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) then
- Ancestor :=
- Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
+ -- The type may be a local derivation, or a type extension of
+ -- a previous formal, or of a formal of a parent package.
+
+ elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
+ or else
+ Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
+ then
+ -- Check whether the parent is another derived formal type
+ -- in the same generic unit.
+
+ if Etype (A_Gen_T) /= A_Gen_T
+ and then Is_Generic_Type (Etype (A_Gen_T))
+ and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
+ and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
+ then
+ -- Locate ancestor of parent from the subtype declaration
+ -- created for the actual.
+
+ declare
+ Decl : Node_Id;
+
+ begin
+ Decl := First (Actual_Decls);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Subtype_Declaration
+ and then Chars (Defining_Identifier (Decl)) =
+ Chars (Etype (A_Gen_T))
+ then
+ Ancestor := Generic_Parent_Type (Decl);
+ exit;
+ else
+ Next (Decl);
+ end if;
+ end loop;
+ end;
+
+ pragma Assert (Present (Ancestor));
+
+ else
+ Ancestor :=
+ Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
+ end if;
else
Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
-- 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);
Abandon_Instantiation (Actual);
end if;
end if;
-
end Validate_Derived_Type_Instance;
------------------------------------
Formal_Subt : Entity_Id;
begin
- if (Is_Limited_Type (Act_T)
- or else Is_Limited_Composite (Act_T))
+ 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 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);
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);
+ -- Deal with fixed/floating restrictions
+
+ if Is_Floating_Point_Type (Act_T) then
+ Check_Restriction (No_Floating_Point, Actual);
+ elsif Is_Fixed_Point_Type (Act_T) then
+ Check_Restriction (No_Fixed_Point, Actual);
+ end if;
+
+ -- Deal with error of using incomplete type as generic actual
+
if Ekind (Act_T) = E_Incomplete_Type then
if No (Underlying_Type (Act_T)) then
Error_Msg_N ("premature use of incomplete type", Actual);
end if;
end if;
+ -- Deal with error of premature use of private type as generic actual
+
elsif Is_Private_Type (Act_T)
and then Is_Private_Type (Base_Type (Act_T))
and then not Is_Generic_Type (Act_T)
if Is_Private_Type (Act_T) then
Set_Has_Private_View (Subtype_Indication (Decl_Node));
+
+ elsif Is_Access_Type (Act_T)
+ and then Is_Private_Type (Designated_Type (Act_T))
+ then
+ Set_Has_Private_View (Subtype_Indication (Decl_Node));
end if;
-- Flag actual derived types so their elaboration produces the
procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id) is
Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec));
+ Save_Style_Check : constant Boolean := Style_Check;
True_Parent : Node_Id;
Inst_Node : Node_Id;
OK : Boolean;
- Save_Style_Check : Boolean := Style_Check;
begin
if not In_Same_Source_Unit (N, Spec)
elsif Nkind (True_Parent) = N_Package_Declaration
and then Present (Generic_Parent (Specification (True_Parent)))
+ and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit
then
-- Parent is an instantiation within another specification.
-- Declaration for instance has been inserted before original
end if;
end loop;
- if Present (Inst_Node) then
+ -- Case where we are currently instantiating a nested generic
+ if Present (Inst_Node) then
if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
-- Instantiation node and declaration of instantiated package
-- body will have been instantiated already.
if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
- Instantiate_Package_Body
- (Pending_Body_Info'(
- Inst_Node, True_Parent, Expander_Active,
- Get_Code_Unit (Sloc (Inst_Node))));
+
+ -- We need to determine the expander mode to instantiate
+ -- the enclosing body. Because the generic body we need
+ -- may use global entities declared in the enclosing package
+ -- (including aggregates) it is in general necessary to
+ -- compile this body with expansion enabled. The exception
+ -- is if we are within a generic package, in which case
+ -- the usual generic rule applies.
+
+ declare
+ Exp_Status : Boolean := True;
+ Scop : Entity_Id;
+
+ begin
+ -- Loop through scopes looking for generic package
+
+ Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node)));
+ while Present (Scop)
+ and then Scop /= Standard_Standard
+ loop
+ if Ekind (Scop) = E_Generic_Package then
+ Exp_Status := False;
+ exit;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ Instantiate_Package_Body
+ (Pending_Body_Info'(
+ Inst_Node, True_Parent, Exp_Status,
+ Get_Code_Unit (Sloc (Inst_Node))));
+ end;
end if;
+ -- Case where we are not instantiating a nested generic
+
else
Opt.Style_Check := False;
+ Expander_Mode_Save_And_Set (True);
Load_Needed_Body (Comp_Unit, OK);
Opt.Style_Check := Save_Style_Check;
+ Expander_Mode_Restore;
if not OK
and then Unit_Requires_Body (Defining_Entity (Spec))
if Circularity_Detected then
raise Unrecoverable_Error;
end if;
-
end Load_Parent_Of_Generic;
-----------------------
procedure Pre_Analyze_Actuals (N : Node_Id) is
Assoc : Node_Id;
Act : Node_Id;
- Errs : Int := Errors_Detected;
+ Errs : constant Int := Serious_Errors_Detected;
begin
Assoc := First (Generic_Associations (N));
-- empty association, so nothing to analyze. If the actual for
-- a subprogram is an attribute, analyze prefix only, because
-- actual is not a complete attribute reference.
+
+ -- If actual is an allocator, analyze expression only. The full
+ -- analysis can generate code, and if the instance is a compilation
+ -- unit we have to wait until the package instance is installed to
+ -- have a proper place to insert this code.
+
-- String literals may be operators, but at this point we do not
-- know whether the actual is a formal subprogram or a string.
elsif Nkind (Act) = N_Explicit_Dereference then
Analyze (Prefix (Act));
+ elsif Nkind (Act) = N_Allocator then
+ declare
+ Expr : constant Node_Id := Expression (Act);
+
+ begin
+ if Nkind (Expr) = N_Subtype_Indication then
+ Analyze (Subtype_Mark (Expr));
+ Analyze_List (Constraints (Constraint (Expr)));
+ else
+ Analyze (Expr);
+ end if;
+ end;
+
elsif Nkind (Act) /= N_Operator_Symbol then
Analyze (Act);
end if;
- if Errs /= Errors_Detected then
+ if Errs /= Serious_Errors_Detected then
Abandon_Instantiation (Act);
end if;
Next_Entity (E);
end loop;
+ if Is_Generic_Instance (Current_Scope)
+ and then P /= Current_Scope
+ then
+ -- We are within an instance of some sibling. Retain
+ -- visibility of parent, for proper subsequent cleanup.
+
+ Set_In_Private_Part (P);
+ end if;
+
+ -- This looks incomplete: what about compilation units that
+ -- were made visible by Install_Parent but should not remain
+ -- visible??? Standard is on the scope stack.
+
elsif not In_Open_Scopes (Scope (P)) then
Set_Is_Immediately_Visible (P, False);
end if;
while Present (S) loop
End_Package_Scope (S);
+ Set_Is_Immediately_Visible (S, False);
S := Current_Scope;
exit when S = Standard_Standard;
end loop;
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
else
declare
- Act_P : Entity_Id := Renamed_Object (E);
- Id : Entity_Id := First_Entity (Act_P);
+ Act_P : constant Entity_Id := Renamed_Object (E);
+ Id : Entity_Id;
begin
+ Id := First_Entity (Act_P);
while Present (Id)
and then Id /= First_Private_Entity (Act_P)
loop
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id)
is
- Saved : Instance_Env;
-
begin
- Saved.Ada_83 := Ada_83;
- Saved.Instantiated_Parent := Current_Instantiated_Parent;
- Saved.Exchanged_Views := Exchanged_Views;
- Saved.Hidden_Entities := Hidden_Entities;
- Saved.Current_Sem_Unit := Current_Sem_Unit;
- Instance_Envs.Increment_Last;
- Instance_Envs.Table (Instance_Envs.Last) := Saved;
-
- -- Regardless of the current mode, predefined units are analyzed in
- -- Ada95 mode, and Ada83 checks don't apply.
-
- if Is_Internal_File_Name
- (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
- Renamings_Included => True) then
- Ada_83 := False;
- end if;
-
- Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
- Exchanged_Views := New_Elmt_List;
- Hidden_Entities := New_Elmt_List;
+ Init_Env;
+ Set_Instance_Env (Gen_Unit, Act_Unit);
end Save_Env;
----------------------------
-- Save semantic information on global entity, so that it is not
-- resolved again at instantiation time.
+ procedure Save_Entity_Descendants (N : Node_Id);
+ -- Apply Save_Global_References to the two syntactic descendants of
+ -- non-terminal nodes that carry an Associated_Node and are processed
+ -- through Reset_Entity. Once the global entity (if any) has been
+ -- captured together with its type, only two syntactic descendants
+ -- need to be traversed to complete the processing of the tree rooted
+ -- at N. This applies to Selected_Components, Expanded_Names, and to
+ -- Operator nodes. N can also be a character literal, identifier, or
+ -- operator symbol node, but the call has no effect in these cases.
+
procedure Save_Global_Defaults (N1, N2 : Node_Id);
-- Default actuals in nested instances must be handled specially
-- because there is no link to them from the original tree. When an
-- context of the parent, we must preserve the identifier of the parent
-- so that it can be properly resolved in a subsequent instantiation.
- procedure Save_Global_Operand_Descendants (N : Node_Id);
- -- Apply Save_Global_Descendant to the possible operand fields
- -- of the node N (Field2 = Left_Opnd, Field3 = Right_Opnd).
- --
- -- It is uncomfortable for Sem_Ch12 to have this knowledge ???
-
procedure Save_Global_Descendant (D : Union_Id);
-- Apply Save_Global_References recursively to the descendents of
-- current node.
-- The type of N2 is global to the generic unit. Save the
-- type in the generic node.
+ function Top_Ancestor (E : Entity_Id) return Entity_Id;
+ -- Find the ultimate ancestor of the current unit. If it is
+ -- not a generic unit, then the name of the current unit
+ -- in the prefix of an expanded name must be replaced with
+ -- its generic homonym to ensure that it will be properly
+ -- resolved in an instance.
+
---------------------
-- Set_Global_Type --
---------------------
end if;
end Set_Global_Type;
+ ------------------
+ -- Top_Ancestor --
+ ------------------
+
+ function Top_Ancestor (E : Entity_Id) return Entity_Id is
+ Par : Entity_Id := E;
+
+ begin
+ while Is_Child_Unit (Par) loop
+ Par := Scope (Par);
+ end loop;
+
+ return Par;
+ end Top_Ancestor;
+
-- Start of processing for Reset_Entity
begin
Change_Selected_Component_To_Expanded_Name (Parent (N));
Set_Associated_Node (Parent (N), Parent (N2));
Set_Global_Type (Parent (N), Parent (N2));
- Save_Global_Operand_Descendants (N);
+ Save_Entity_Descendants (N);
- -- If this is a reference to the current generic entity,
- -- replace it with a simple name. This is to avoid anomalies
- -- when the enclosing scope is also a generic unit, in which
- -- case the selected component will not resolve to the current
- -- unit within an instance of the outer one. Ditto if the
- -- entity is an enclosing scope, e.g. a parent unit.
+ -- If this is a reference to the current generic entity,
+ -- replace by the name of the generic homonym of the current
+ -- package. This is because in an instantiation Par.P.Q will
+ -- not resolve to the name of the instance, whose enclosing
+ -- scope is not necessarily Par. We use the generic homonym
+ -- rather that the name of the generic itself, because it may
+ -- be hidden by a local declaration.
elsif In_Open_Scopes (Entity (Parent (N2)))
- and then not Is_Generic_Unit (Entity (Prefix (Parent (N2))))
+ and then not
+ Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2)))))
then
- Rewrite (Parent (N),
- Make_Identifier (Sloc (N),
- Chars => Chars (Selector_Name (Parent (N2)))));
+ if Ekind (Entity (Parent (N2))) = E_Generic_Package then
+ Rewrite (Parent (N),
+ Make_Identifier (Sloc (N),
+ Chars =>
+ Chars (Generic_Homonym (Entity (Parent (N2))))));
+ else
+ Rewrite (Parent (N),
+ Make_Identifier (Sloc (N),
+ Chars => Chars (Selector_Name (Parent (N2)))));
+ end if;
end if;
if (Nkind (Parent (Parent (N))) = N_Package_Instantiation
Change_Selected_Component_To_Expanded_Name (Parent (N));
Set_Associated_Node (Parent (N), Name (Parent (N2)));
Set_Global_Type (Parent (N), Name (Parent (N2)));
- Save_Global_Operand_Descendants (N);
+ Save_Entity_Descendants (N);
else
-- Entity is local. Reset in generic unit, so that node
end if;
end Reset_Entity;
+ -----------------------------
+ -- Save_Entity_Descendants --
+ -----------------------------
+
+ procedure Save_Entity_Descendants (N : Node_Id) is
+ begin
+ case Nkind (N) is
+ when N_Binary_Op =>
+ Save_Global_Descendant (Union_Id (Left_Opnd (N)));
+ Save_Global_Descendant (Union_Id (Right_Opnd (N)));
+
+ when N_Unary_Op =>
+ Save_Global_Descendant (Union_Id (Right_Opnd (N)));
+
+ when N_Expanded_Name | N_Selected_Component =>
+ Save_Global_Descendant (Union_Id (Prefix (N)));
+ Save_Global_Descendant (Union_Id (Selector_Name (N)));
+
+ when N_Identifier | N_Character_Literal | N_Operator_Symbol =>
+ null;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Save_Entity_Descendants;
+
--------------------------
-- Save_Global_Defaults --
--------------------------
procedure Save_Global_Defaults (N1, N2 : Node_Id) is
Loc : constant Source_Ptr := Sloc (N1);
- Assoc1 : List_Id := Generic_Associations (N1);
- Assoc2 : List_Id := Generic_Associations (N2);
+ Assoc2 : constant List_Id := Generic_Associations (N2);
+ Gen_Id : constant Entity_Id := Get_Generic_Entity (N2);
+ Assoc1 : List_Id;
Act1 : Node_Id;
Act2 : Node_Id;
Def : Node_Id;
- Gen_Id : Entity_Id := Entity (Name (N2));
Ndec : Node_Id;
Subp : Entity_Id;
Actual : Entity_Id;
begin
+ Assoc1 := Generic_Associations (N1);
+
if Present (Assoc1) then
Act1 := First (Assoc1);
else
end if;
end Save_Global_Descendant;
- -------------------------------------
- -- Save_Global_Operand_Descendants --
- -------------------------------------
-
- procedure Save_Global_Operand_Descendants (N : Node_Id) is
-
- use Atree.Unchecked_Access;
- -- This code section is part of the implementation of an untyped
- -- tree traversal, so it needs direct access to node fields.
-
- begin
- Save_Global_Descendant (Field2 (N));
- Save_Global_Descendant (Field3 (N));
- end Save_Global_Operand_Descendants;
-
---------------------
-- Save_References --
---------------------
if N = Empty then
null;
- elsif (Nkind (N) = N_Character_Literal
- or else Nkind (N) = N_Operator_Symbol)
+ elsif Nkind (N) = N_Character_Literal
+ or else Nkind (N) = N_Operator_Symbol
then
if Nkind (N) = Nkind (Get_Associated_Node (N)) then
Reset_Entity (N);
elsif Nkind (N2) = N_Integer_Literal
or else Nkind (N2) = N_Real_Literal
or else Nkind (N2) = N_String_Literal
- or else (Nkind (N2) = N_Identifier
- and then
- Ekind (Entity (N2)) = E_Enumeration_Literal)
then
-- Operation was constant-folded, perform the same
-- replacement in generic.
- -- Note: we do a Replace here rather than a Rewrite,
- -- which is a definite violation of the standard rules
- -- with regard to retrievability of the original tree,
- -- and likely ASIS bugs or at least irregularities are
- -- caused by this choice.
-
- -- The reason we do this is that the appropriate original
- -- nodes are never constructed (we don't go applying the
- -- generic instantiation to rewritten nodes in general).
- -- We could try to create an appropriate copy but it would
- -- be hard work and does not seem worth while, because
- -- the original expression is accessible in the generic,
- -- and ASIS rules for traversing instances are fuzzy.
-
- Replace (N, New_Copy (N2));
+ Rewrite (N, New_Copy (N2));
+ Set_Analyzed (N, False);
+
+ elsif Nkind (N2) = N_Identifier
+ and then Ekind (Entity (N2)) = E_Enumeration_Literal
+ then
+ -- Same if call was folded into a literal, but in this
+ -- case retain the entity to avoid spurious ambiguities
+ -- if id is overloaded at the point of instantiation or
+ -- inlining.
+
+ Rewrite (N, New_Copy (N2));
Set_Analyzed (N, False);
end if;
end if;
- -- Complete the check on operands
+ -- Complete the check on operands, if node has not been
+ -- constant-folded.
- Save_Global_Operand_Descendants (N);
+ if Nkind (N) in N_Op then
+ Save_Entity_Descendants (N);
+ end if;
elsif Nkind (N) = N_Identifier then
if Nkind (N) = Nkind (Get_Associated_Node (N)) then
Save_References (N);
end Save_Global_References;
- ---------------------
- -- Set_Copied_Sloc --
- ---------------------
+ --------------------------------------
+ -- Set_Copied_Sloc_For_Inlined_Body --
+ --------------------------------------
- procedure Set_Copied_Sloc (N : Node_Id; E : Entity_Id) is
+ procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
begin
- Create_Instantiation_Source (N, E, S_Adjustment);
- end Set_Copied_Sloc;
+ Create_Instantiation_Source (N, E, True, S_Adjustment);
+ end Set_Copied_Sloc_For_Inlined_Body;
---------------------
-- Set_Instance_Of --
Expander_Mode_Save_And_Set (False);
end Start_Generic;
+ ----------------------
+ -- Set_Instance_Env --
+ ----------------------
+
+ procedure Set_Instance_Env
+ (Gen_Unit : Entity_Id;
+ Act_Unit : Entity_Id)
+ is
+
+ begin
+ -- Regardless of the current mode, predefined units are analyzed in
+ -- the most current Ada mode, and earlier version Ada checks do not
+ -- apply to predefined units.
+
+ if Is_Internal_File_Name
+ (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
+ Renamings_Included => True) then
+ Ada_Version := Ada_Version_Type'Last;
+ end if;
+
+ Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
+ end Set_Instance_Env;
+
-----------------
-- Switch_View --
-----------------
procedure Switch_View (T : Entity_Id) is
+ BT : constant Entity_Id := Base_Type (T);
Priv_Elmt : Elmt_Id := No_Elmt;
Priv_Sub : Entity_Id;
- BT : Entity_Id := Base_Type (T);
begin
-- T may be private but its base type may have been exchanged through
procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
Attr_Id : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (Def));
+ T : constant Entity_Id := Entity (Prefix (Def));
+ Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
F : Entity_Id;
Num_F : Int;
- T : Entity_Id := Entity (Prefix (Def));
OK : Boolean;
- Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
begin
if No (T)
end loop;
case Attr_Id is
- when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
- Attribute_Floor | Attribute_Fraction | Attribute_Machine |
- Attribute_Model | Attribute_Remainder | Attribute_Rounding |
- Attribute_Unbiased_Rounding =>
- OK := (Is_Fun and then Num_F = 1 and then Is_Floating_Point_Type (T));
+ when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
+ Attribute_Floor | Attribute_Fraction | Attribute_Machine |
+ Attribute_Model | Attribute_Remainder | Attribute_Rounding |
+ Attribute_Unbiased_Rounding =>
+ OK := Is_Fun
+ and then Num_F = 1
+ and then Is_Floating_Point_Type (T);
- when Attribute_Image | Attribute_Pred | Attribute_Succ |
- Attribute_Value | Attribute_Wide_Image |
- Attribute_Wide_Value =>
- OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
+ when Attribute_Image | Attribute_Pred | Attribute_Succ |
+ Attribute_Value | Attribute_Wide_Image |
+ Attribute_Wide_Value =>
+ OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
- when Attribute_Max | Attribute_Min =>
- OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
+ when Attribute_Max | Attribute_Min =>
+ OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
- when Attribute_Input =>
- OK := (Is_Fun and then Num_F = 1);
+ when Attribute_Input =>
+ OK := (Is_Fun and then Num_F = 1);
- when Attribute_Output | Attribute_Read | Attribute_Write =>
- OK := (not Is_Fun and then Num_F = 2);
+ when Attribute_Output | Attribute_Read | Attribute_Write =>
+ OK := (not Is_Fun and then Num_F = 2);
- when others => OK := False;
+ when others =>
+ OK := False;
end case;
if not OK then
OSDN Git Service
