-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Fname.UF; use Fname.UF;
with Freeze; use Freeze;
with Hostparm;
+with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
-- illegal circular instantiation.
function Denotes_Formal_Package
- (Pack : Entity_Id;
- On_Exit : Boolean := False) return Boolean;
+ (Pack : Entity_Id;
+ On_Exit : Boolean := False;
+ Instance : Entity_Id := Empty) return Boolean;
-- Returns True if E is a formal package of an enclosing generic, or
-- the actual for such a formal in an enclosing instantiation. If such
-- a package is used as a formal in an nested generic, or as an actual
-- in a nested instantiation, the visibility of ITS formals should not
-- be modified. When called from within Restore_Private_Views, the flag
-- On_Exit is true, to indicate that the search for a possible enclosing
- -- instance should ignore the current one.
+ -- instance should ignore the current one. In that case Instance denotes
+ -- the declaration for which this is an actual. This declaration may be
+ -- an instantiation in the source, or the internal instantiation that
+ -- corresponds to the actual for a formal package.
function Find_Actual_Type
(Typ : Entity_Id;
Inst : Node_Id) return Boolean;
-- True if the instantiation Inst and the given freeze_node F_Node appear
-- within the same declarative part, ignoring subunits, but with no inter-
- -- vening suprograms or concurrent units. If true, the freeze node
+ -- vening subprograms or concurrent units. If true, the freeze node
-- of the instance can be placed after the freeze node of the parent,
-- which it itself an instance.
-- loaded. In that case a missing body is acceptable.
procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
- -- Add the context clause of the unit containing a generic unit to an
- -- instantiation that is a compilation unit.
+ -- Add the context clause of the unit containing a generic unit to a
+ -- compilation unit that is, or contains, an instantiation.
function Get_Associated_Node (N : Node_Id) return Node_Id;
-- In order to propagate semantic information back from the analyzed copy
-- 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.
+ procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id);
+ -- Within the generic part, entities in the formal package are
+ -- visible. To validate subsequent type declarations, indicate
+ -- the correspondence between the entities in the analyzed formal,
+ -- and the entities in the actual package. There are three packages
+ -- involved in the instantiation of a formal package: the parent
+ -- generic P1 which appears in the generic declaration, the fake
+ -- instantiation P2 which appears in the analyzed generic, and whose
+ -- visible entities may be used in subsequent formals, and the actual
+ -- P3 in the instance. To validate subsequent formals, me indicate
+ -- that the entities in P2 are mapped into those of P3. The mapping of
+ -- entities has to be done recursively for nested packages.
+
procedure Move_Freeze_Nodes
(Out_Of : Entity_Id;
After : Node_Id;
Formals : List_Id;
F_Copy : List_Id) return List_Id
is
- Actual_Types : constant Elist_Id := New_Elmt_List;
- Assoc : constant List_Id := New_List;
+
+ Actual_Types : constant Elist_Id := New_Elmt_List;
+ Assoc : constant List_Id := New_List;
Default_Actuals : constant Elist_Id := New_Elmt_List;
- Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy));
+ Gen_Unit : constant Entity_Id :=
+ Defining_Entity (Parent (F_Copy));
+
Actuals : List_Id;
Actual : Node_Id;
Formal : Node_Id;
First_Named : Node_Id := Empty;
Default_Formals : constant List_Id := New_List;
- -- If an Other_Choice is present, some of the formals may be defaulted.
+ -- If an Others_Choice is present, some of the formals may be defaulted.
-- To simplify the treatment of visibility in an instance, we introduce
-- individual defaults for each such formal. These defaults are
-- appended to the list of associations and replace the Others_Choice.
- Found_Assoc : Node_Id;
+ Found_Assoc : Node_Id;
-- Association for the current formal being match. Empty if there are
-- no remaining actuals, or if there is no named association with the
-- name of the formal.
- Is_Named_Assoc : Boolean;
- Num_Matched : Int := 0;
- Num_Actuals : Int := 0;
+ Is_Named_Assoc : Boolean;
+ Num_Matched : Int := 0;
+ Num_Actuals : Int := 0;
- Others_Present : Boolean := False;
- -- In Ada 2005, indicates partial parametrization of of a formal
- -- package. As usual an others association must be last in the list.
+ Others_Present : Boolean := False;
+ -- In Ada 2005, indicates partial parametrization of a formal
+ -- package. As usual an other association must be last in the list.
function Matching_Actual
(F : Entity_Id;
-- End of list of purely positional parameters
- if No (Actual)
- or else Nkind (Actual) = N_Others_Choice
- then
+ if No (Actual) or else Nkind (Actual) = N_Others_Choice then
Found_Assoc := Empty;
Act := Empty;
procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node);
F_Id : constant Entity_Id := Defining_Entity (F);
-
Decl : Node_Id;
Default : Node_Id;
Id : Entity_Id;
begin
- -- Append copy of formal declaration to associations, and create
- -- new defining identifier for it.
+ -- Append copy of formal declaration to associations, and create new
+ -- defining identifier for it.
Decl := New_Copy_Tree (F);
Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id));
if Present (Actuals) then
- -- check for an Others choice, indicating a partial parametrization
+ -- Check for an Others choice, indicating a partial parametrization
-- for a formal package.
Actual := First (Actuals);
Defining_Unit_Name (Specification (Formal)),
Defining_Unit_Name (Specification (Analyzed_Formal)));
- -- If the formal subprogram has the same name as
- -- another formal subprogram of the generic, then
- -- a named association is illegal (12.3(9)). Exclude
- -- named associations that are generated for a nested
- -- instance.
+ -- If the formal subprogram has the same name as another
+ -- formal subprogram of the generic, then a named
+ -- association is illegal (12.3(9)). Exclude named
+ -- associations that are generated for a nested instance.
if Present (Match)
and then Is_Named_Assoc
declare
Elmt : Elmt_Id := First_Elmt (Actual_Types);
-
begin
while Present (Elmt) loop
Freeze_Before (I_Node, Node (Elmt));
Find_Type (Subtype_Mark (N));
T := Entity (Subtype_Mark (N));
+ -- Verify that there is no redundant null exclusion
+
+ if Null_Exclusion_Present (N) then
+ if not Is_Access_Type (T) then
+ Error_Msg_N
+ ("null exclusion can only apply to an access type", N);
+
+ elsif Can_Never_Be_Null (T) then
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ N, T);
+ end if;
+ end if;
+
-- Ada 2005 (AI-423): Formal object with an access definition
else
if Present (E) then
Preanalyze_Spec_Expression (E, T);
- if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then
+ if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then
Error_Msg_N
("initialization not allowed for limited types", E);
Explain_Limited_Type (T, E);
("initialization not allowed for `IN OUT` formals", N);
end if;
end if;
-
end Analyze_Formal_Object_Declaration;
----------------------------------------------
procedure Analyze_Formal_Package (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Pack_Id : constant Entity_Id := Defining_Identifier (N);
+ Pack_Id : constant Entity_Id := Defining_Identifier (N);
Formal : Entity_Id;
Gen_Id : constant Node_Id := Name (N);
Gen_Decl : Node_Id;
-- create corresponding declarations for all entities in the formal
-- part, so that names with the proper types are available in the
-- specification of the formal package.
+
-- On the other hand, if there are no associations, then all the
-- formals must have defaults, and this will be checked by the
-- call to Analyze_Associations.
Error_Msg_N ("no visible entity matches specification", Def);
end if;
- else
-
- -- Several interpretations. Disambiguate as for a renaming.
+ -- More than one interpretation, so disambiguate as for a renaming
+ else
declare
I : Interp_Index;
I1 : Interp_Index := 0;
Subp := Any_Id;
Get_First_Interp (Def, I, It);
while Present (It.Nam) loop
-
if Entity_Matches_Spec (It.Nam, Nam) then
if Subp /= Any_Id then
It1 := Disambiguate (Def, I1, I, Etype (Subp));
New_N : Node_Id;
Result_Type : Entity_Id;
Save_Parent : Node_Id;
+ Typ : Entity_Id;
begin
-- Create copy of generic unit, and save for instantiation. If the unit
Set_Etype (Id, Result_Type);
else
Find_Type (Result_Definition (Spec));
- Set_Etype (Id, Entity (Result_Definition (Spec)));
+ Typ := Entity (Result_Definition (Spec));
+
+ -- If a null exclusion is imposed on the result type, then create
+ -- a null-excluding itype (an access subtype) and use it as the
+ -- function's Etype.
+
+ if Is_Access_Type (Typ)
+ and then Null_Exclusion_Present (Spec)
+ then
+ Set_Etype (Id,
+ Create_Null_Excluding_Itype
+ (T => Typ,
+ Related_Nod => Spec,
+ Scope_Id => Defining_Unit_Name (Spec)));
+ else
+ Set_Etype (Id, Typ);
+ end if;
end if;
else
Init_Env;
Env_Installed := True;
+
+ -- Reset renaming map for formal types. The mapping is established
+ -- when analyzing the generic associations, but some mappings are
+ -- inherited from formal packages of parent units, and these are
+ -- constructed when the parents are installed.
+
+ Generic_Renamings.Set_Last (0);
+ Generic_Renamings_HTable.Reset;
+
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
-- Verify that it is the name of a generic package
+ -- A visibility glitch: if the instance is a child unit and the generic
+ -- is the generic unit of a parent instance (i.e. both the parent and
+ -- the child units are instances of the same package) the name now
+ -- denotes the renaming within the parent, not the intended generic
+ -- unit. See if there is a homonym that is the desired generic. The
+ -- renaming declaration must be visible inside the instance of the
+ -- child, but not when analyzing the name in the instantiation itself.
+
+ if Ekind (Gen_Unit) = E_Package
+ and then Present (Renamed_Entity (Gen_Unit))
+ and then In_Open_Scopes (Renamed_Entity (Gen_Unit))
+ and then Is_Generic_Instance (Renamed_Entity (Gen_Unit))
+ and then Present (Homonym (Gen_Unit))
+ then
+ Gen_Unit := Homonym (Gen_Unit);
+ end if;
+
if Etype (Gen_Unit) = Any_Type then
Restore_Env;
return;
-- validate an actual package, the instantiation environment is that
-- of the enclosing instance.
- Generic_Renamings.Set_Last (0);
- Generic_Renamings_HTable.Reset;
-
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation
Validate_Categorization_Dependency (N, Act_Decl_Id);
- -- Check restriction, but skip this if something went wrong in the above
- -- analysis, indicated by Act_Decl_Id being void.
+ -- There used to be a check here to prevent instantiations in local
+ -- contexts if the No_Local_Allocators restriction was active. This
+ -- check was removed by a binding interpretation in AI-95-00130/07,
+ -- but we retain the code for documentation purposes.
- if Ekind (Act_Decl_Id) /= E_Void
- and then not Is_Library_Level_Entity (Act_Decl_Id)
- then
- Check_Restriction (No_Local_Allocators, N);
- end if;
+ -- if Ekind (Act_Decl_Id) /= E_Void
+ -- and then not Is_Library_Level_Entity (Act_Decl_Id)
+ -- then
+ -- Check_Restriction (No_Local_Allocators, N);
+ -- end if;
if Inline_Now then
Inline_Instance_Body (N, Gen_Unit, Act_Decl);
Analyze_Subprogram_Instantiation (N, E_Procedure);
end Analyze_Procedure_Instantiation;
+ -----------------------------------
+ -- Need_Subprogram_Instance_Body --
+ -----------------------------------
+
+ function Need_Subprogram_Instance_Body
+ (N : Node_Id;
+ Subp : Entity_Id) return Boolean
+ is
+ begin
+ if (Is_In_Main_Unit (N)
+ or else Is_Inlined (Subp)
+ or else Is_Inlined (Alias (Subp)))
+ and then (Operating_Mode = Generate_Code
+ or else (Operating_Mode = Check_Semantics
+ and then ASIS_Mode))
+ and then (Expander_Active or else ASIS_Mode)
+ and then not ABE_Is_Certain (N)
+ and then not Is_Eliminated (Subp)
+ then
+ Pending_Instantiations.Append
+ ((Inst_Node => N,
+ Act_Decl => Unit_Declaration_Node (Subp),
+ Expander_Status => Expander_Active,
+ Current_Sem_Unit => Current_Sem_Unit,
+ Scope_Suppress => Scope_Suppress,
+ Local_Suppress_Stack_Top => Local_Suppress_Stack_Top));
+ return True;
+ else
+ return False;
+ end if;
+ end Need_Subprogram_Instance_Body;
+
--------------------------------------
-- Analyze_Subprogram_Instantiation --
--------------------------------------
-- If the context requires a full instantiation, mark node for
-- subsequent construction of the body.
- if (Is_In_Main_Unit (N)
- or else Is_Inlined (Act_Decl_Id))
- and then (Operating_Mode = Generate_Code
- or else (Operating_Mode = Check_Semantics
- 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.Append
- ((Inst_Node => N,
- Act_Decl => Act_Decl,
- Expander_Status => Expander_Active,
- Current_Sem_Unit => Current_Sem_Unit,
- Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top));
+ if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then
Check_Forward_Instantiation (Gen_Decl);
Make_Compilation_Unit_Aux (Sloc (N)));
Set_Parent_Spec (Act_Decl, Parent_Spec (N));
- Set_Body_Required (Decl_Cunit, True);
+
+ -- The new compilation unit is linked to its body, but both share the
+ -- same file, so we do not set Body_Required on the new unit so as not
+ -- to create a spurious dependency on a non-existent body in the ali.
+ -- This simplifies CodePeer unit traversal.
-- We use the original instantiation compilation unit as the resulting
-- compilation unit of the instance, since this is the main unit.
Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
- -- If the instance is not the main unit, its context, categorization,
+ -- 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
+ if Body_Cunit /= Cunit (Main_Unit) then
+ Make_Instance_Unit (Body_Cunit, In_Main => False);
return;
end if;
-- Make entry in Units table, so that binder can generate call to
-- elaboration procedure for body, if any.
- Make_Instance_Unit (Body_Cunit);
+ Make_Instance_Unit (Body_Cunit, In_Main => True);
Main_Unit_Entity := New_Main;
Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
Inst_Par := Entity (Prefix (Gen_Id));
while Present (Inst_Par)
- and then Ekind (Inst_Par) /= E_Package
- and then Ekind (Inst_Par) /= E_Generic_Package
+ and then not Is_Package_Or_Generic_Package (Inst_Par)
loop
Inst_Par := Homonym (Inst_Par);
end loop;
then
if not Instantiating then
- -- Link both nodes in order to assign subsequently the
- -- entity of the copy to the original node, in case this
- -- is a global reference.
+ -- Link both nodes in order to assign subsequently the entity of
+ -- the copy to the original node, in case this is a global
+ -- reference.
Set_Associated_Node (N, New_N);
----------------------------
function Denotes_Formal_Package
- (Pack : Entity_Id;
- On_Exit : Boolean := False) return Boolean
+ (Pack : Entity_Id;
+ On_Exit : Boolean := False;
+ Instance : Entity_Id := Empty) return Boolean
is
Par : Entity_Id;
Scop : constant Entity_Id := Scope (Pack);
E : Entity_Id;
+ function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
+ -- The package in question may be an actual for a previous formal
+ -- package P of the current instance, so examine its actuals as well.
+ -- This must be recursive over other formal packages.
+
+ ----------------------------------
+ -- Is_Actual_Of_Previous_Formal --
+ ----------------------------------
+
+ function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is
+ E1 : Entity_Id;
+
+ begin
+ E1 := First_Entity (P);
+ while Present (E1) and then E1 /= Instance loop
+ if Ekind (E1) = E_Package
+ and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
+ then
+ if Renamed_Object (E1) = Pack then
+ return True;
+
+ elsif E1 = P
+ or else Renamed_Object (E1) = P
+ then
+ return False;
+
+ elsif Is_Actual_Of_Previous_Formal (E1) then
+ return True;
+ end if;
+ end if;
+
+ Next_Entity (E1);
+ end loop;
+
+ return False;
+ end Is_Actual_Of_Previous_Formal;
+
+ -- Start of processing for Denotes_Formal_Package
+
begin
if On_Exit then
Par :=
elsif Renamed_Object (E) = Pack then
return True;
+
+ elsif Is_Actual_Of_Previous_Formal (E) then
+ return True;
+
end if;
Next_Entity (E);
Item := First (Context_Items (Parent (Gen_Decl)));
while Present (Item) loop
if Nkind (Item) = N_With_Clause then
- New_I := New_Copy (Item);
- Set_Implicit_With (New_I, True);
- Append (New_I, Current_Context);
+
+ -- Take care to prevent direct cyclic with's, which can happen
+ -- if the generic body with's the current unit. Such a case
+ -- would result in binder errors (or run-time errors if the
+ -- -gnatE switch is in effect), but we want to prevent it here,
+ -- because Sem.Walk_Library_Items doesn't like cycles. Note
+ -- that we don't bother to detect indirect cycles.
+
+ if Library_Unit (Item) /= Current_Unit then
+ New_I := New_Copy (Item);
+ Set_Implicit_With (New_I, True);
+ Append (New_I, Current_Context);
+ end if;
end if;
Next (Item);
-----------------------------
procedure Install_Formal_Packages (Par : Entity_Id) is
- E : Entity_Id;
+ E : Entity_Id;
+ Gen : Entity_Id;
+ Gen_E : Entity_Id := Empty;
begin
E := First_Entity (Par);
+
+ -- In we are installing an instance parent, locate the formal packages
+ -- of its generic parent.
+
+ if Is_Generic_Instance (Par) then
+ Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par)));
+ Gen_E := First_Entity (Gen);
+ end if;
+
while Present (E) loop
if Ekind (E) = E_Package
and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
then
Check_Generic_Actuals (Renamed_Object (E), True);
Set_Is_Hidden (E, False);
+
+ -- Find formal package in generic unit that corresponds to
+ -- (instance of) formal package in instance.
+
+ while Present (Gen_E)
+ and then Chars (Gen_E) /= Chars (E)
+ loop
+ Next_Entity (Gen_E);
+ end loop;
+
+ if Present (Gen_E) then
+ Map_Formal_Package_Entities (Gen_E, E);
+ end if;
end if;
end if;
Next_Entity (E);
+ if Present (Gen_E) then
+ Next_Entity (Gen_E);
+ end if;
end loop;
end Install_Formal_Packages;
-- 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
- -- the correspondence between the entities in the analyzed formal,
- -- and the entities in the actual package. There are three packages
- -- involved in the instantiation of a formal package: the parent
- -- generic P1 which appears in the generic declaration, the fake
- -- instantiation P2 which appears in the analyzed generic, and whose
- -- visible entities may be used in subsequent formals, and the actual
- -- P3 in the instance. To validate subsequent formals, me indicate
- -- that the entities in P2 are mapped into those of P3. The mapping of
- -- entities has to be done recursively for nested packages.
-
procedure Process_Nested_Formal (Formal : Entity_Id);
-- If the current formal is declared with a box, its own formals are
-- visible in the instance, as they were in the generic, and their
end if;
end Is_Instance_Of;
- ------------------
- -- Map_Entities --
- ------------------
-
- procedure Map_Entities (Form : Entity_Id; Act : Entity_Id) is
- E1 : Entity_Id;
- E2 : Entity_Id;
-
- 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)
- and then E1 /= First_Private_Entity (Form)
- loop
- -- Could this test be a single condition???
- -- Seems like it could, and isn't FPE (Form) a constant anyway???
-
- if not Is_Internal (E1)
- and then Present (Parent (E1))
- and then not Is_Class_Wide_Type (E1)
- and then not Is_Internal_Name (Chars (E1))
- then
- while Present (E2)
- and then Chars (E2) /= Chars (E1)
- loop
- Next_Entity (E2);
- end loop;
-
- if No (E2) then
- exit;
- else
- Set_Instance_Of (E1, E2);
-
- if Is_Type (E1)
- and then Is_Tagged_Type (E2)
- then
- Set_Instance_Of
- (Class_Wide_Type (E1), Class_Wide_Type (E2));
- end if;
-
- if Ekind (E1) = E_Package
- and then No (Renamed_Object (E1))
- then
- Map_Entities (E1, E2);
- end if;
- end if;
- end if;
-
- Next_Entity (E1);
- end loop;
- end Map_Entities;
-
---------------------------
-- Process_Nested_Formal --
---------------------------
end if;
Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
- Map_Entities (Formal_Pack, Actual_Pack);
+ Map_Formal_Package_Entities (Formal_Pack, Actual_Pack);
Nod :=
Make_Package_Renaming_Declaration (Loc,
"with volatile actual", Actual);
end if;
- -- OUT not present
+ -- formal in-parameter
else
-- The instantiation of a generic formal in-parameter is constant
Decl_Node :=
Make_Object_Declaration (Loc,
- Defining_Identifier => New_Copy (Formal_Id),
- Constant_Present => True,
- Object_Definition => New_Copy_Tree (Def),
- Expression => Actual);
+ Defining_Identifier => New_Copy (Formal_Id),
+ Constant_Present => True,
+ Null_Exclusion_Present => Null_Exclusion_Present (Formal),
+ Object_Definition => New_Copy_Tree (Def),
+ Expression => Actual);
Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
end if;
declare
- Typ : constant Entity_Id :=
- Get_Instance_Of
- (Etype (Defining_Identifier (Analyzed_Formal)));
+ Formal_Object : constant Entity_Id :=
+ Defining_Identifier (Analyzed_Formal);
+ Formal_Type : constant Entity_Id := Etype (Formal_Object);
+
+ Typ : Entity_Id;
begin
+ Typ := Get_Instance_Of (Formal_Type);
+
Freeze_Before (Instantiation_Node, Typ);
-- If the actual is an aggregate, perform name resolution on
end if;
if Is_Limited_Type (Typ)
- and then not OK_For_Limited_Init (Actual)
+ and then not OK_For_Limited_Init (Typ, Actual)
then
Error_Msg_N
("initialization not allowed for limited types", Actual);
Decl_Node :=
Make_Object_Declaration (Sloc (Formal),
- Defining_Identifier => New_Copy (Formal_Id),
- Constant_Present => True,
- Object_Definition => New_Copy (Def),
- Expression => New_Copy_Tree (Default_Expression
- (Formal)));
+ Defining_Identifier => New_Copy (Formal_Id),
+ Constant_Present => True,
+ Null_Exclusion_Present => Null_Exclusion_Present (Formal),
+ Object_Definition => New_Copy (Def),
+ Expression => New_Copy_Tree
+ (Default_Expression (Formal)));
Append (Decl_Node, List);
Set_Analyzed (Expression (Decl_Node), False);
Decl_Node :=
Make_Object_Declaration (Loc,
- Defining_Identifier => New_Copy (Formal_Id),
- Constant_Present => True,
- Object_Definition => New_Copy (Def),
- Expression =>
- Make_Attribute_Reference (Sloc (Formal_Id),
- Attribute_Name => Name_First,
- Prefix => New_Copy (Def)));
+ Defining_Identifier => New_Copy (Formal_Id),
+ Constant_Present => True,
+ Null_Exclusion_Present => Null_Exclusion_Present (Formal),
+ Object_Definition => New_Copy (Def),
+ Expression =>
+ Make_Attribute_Reference (Sloc (Formal_Id),
+ Attribute_Name => Name_First,
+ Prefix => New_Copy (Def)));
Append (Decl_Node, List);
Parent_Installed : Boolean := False;
Save_Style_Check : constant Boolean := Style_Check;
+ Par_Ent : Entity_Id := Empty;
+ Par_Vis : Boolean := False;
+
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
if Ekind (Scope (Gen_Unit)) = E_Generic_Package
and then Nkind (Gen_Id) = N_Expanded_Name
then
- Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
+ Par_Ent := Entity (Prefix (Gen_Id));
+ Par_Vis := Is_Immediately_Visible (Par_Ent);
+ Install_Parent (Par_Ent, In_Body => True);
Parent_Installed := True;
elsif Is_Child_Unit (Gen_Unit) then
- Install_Parent (Scope (Gen_Unit), In_Body => True);
+ Par_Ent := Scope (Gen_Unit);
+ Par_Vis := Is_Immediately_Visible (Par_Ent);
+ Install_Parent (Par_Ent, In_Body => True);
Parent_Installed := True;
end if;
if Parent_Installed then
Remove_Parent (In_Body => True);
+
+ -- Restore the previous visibility of the parent
+
+ Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
end if;
Restore_Private_Views (Act_Decl_Id);
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 := Get_Generic_Entity (Inst_Node);
- Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
- Anon_Id : constant Entity_Id :=
+ Gen_Id : constant Node_Id := 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 :=
+ Pack_Id : constant Entity_Id :=
Defining_Unit_Name (Parent (Act_Decl));
Decls : List_Id;
Gen_Body : Node_Id;
Parent_Installed : Boolean := False;
Save_Style_Check : constant Boolean := Style_Check;
+ Par_Ent : Entity_Id := Empty;
+ Par_Vis : Boolean := False;
+
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
+ -- Subprogram body may have been created already because of an inline
+ -- pragma, or because of multiple elaborations of the enclosing package
+ -- when several instances of the subprogram appear in the main unit.
+
+ if Present (Corresponding_Body (Act_Decl)) then
+ return;
+ end if;
+
Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
-- Re-establish the state of information on which checks are suppressed.
if Ekind (Scope (Gen_Unit)) = E_Generic_Package
and then Nkind (Gen_Id) = N_Expanded_Name
then
- Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
+ Par_Ent := Entity (Prefix (Gen_Id));
+ Par_Vis := Is_Immediately_Visible (Par_Ent);
+ Install_Parent (Par_Ent, In_Body => True);
Parent_Installed := True;
elsif Is_Child_Unit (Gen_Unit) then
- Install_Parent (Scope (Gen_Unit), In_Body => True);
+ Par_Ent := Scope (Gen_Unit);
+ Par_Vis := Is_Immediately_Visible (Par_Ent);
+ Install_Parent (Par_Ent, In_Body => True);
Parent_Installed := True;
end if;
if Parent_Installed then
Remove_Parent (In_Body => True);
+
+ -- Restore the previous visibility of the parent
+
+ Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
end if;
Restore_Env;
Next_Index (I2);
end loop;
- if not Subtypes_Match
- (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
- Component_Type (Act_T))
+ -- Check matching subtypes. Note that there are complex visibility
+ -- issues when the generic is a child unit and some aspect of the
+ -- generic type is declared in a parent unit of the generic. We do
+ -- the test to handle this special case only after a direct check
+ -- for static matching has failed.
+
+ if Subtypes_Match
+ (Component_Type (A_Gen_T), Component_Type (Act_T))
+ or else Subtypes_Match
+ (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
+ Component_Type (Act_T))
then
+ null;
+ else
Error_Msg_NE
("component subtype of actual does not match that of formal &",
Actual, Gen_T);
-- Now verify that the actual includes all other ancestors of
-- the formal.
- Elmt := First_Elmt (Abstract_Interfaces (A_Gen_T));
+ Elmt := First_Elmt (Interfaces (A_Gen_T));
while Present (Elmt) loop
if not Interface_Present_In_Ancestor
(Act_T, Get_Instance_Of (Node (Elmt)))
Abandon_Instantiation (Actual);
end if;
- -- This case should be caught by the earlier check for for
+ -- This case should be caught by the earlier check for
-- constrainedness, but the check here is added for completeness.
elsif Has_Discriminants (Act_T)
function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean
is
- Interfaces : Elist_Id;
Intfc_Elmt : Elmt_Id;
begin
-- progenitors.
else
- Interfaces := Abstract_Interfaces (T2);
-
- Intfc_Elmt := First_Elmt (Interfaces);
+ Intfc_Elmt := First_Elmt (Interfaces (T2));
while Present (Intfc_Elmt) loop
if Is_Ancestor (T1, Node (Intfc_Elmt)) then
return True;
-- declared without a box (see Instantiate_Formal_Package). Such
-- an instantiation does not generate any code (the actual code
-- comes from actual) and thus does not need to be analyzed here.
+ -- If the instantiation appears with a generic package body it is
+ -- not analyzed here either.
elsif Nkind (Decl) = N_Package_Instantiation
and then not Is_Internal (Defining_Entity (Decl))
then
Append_Elmt (Decl, Previous_Instances);
- -- For a subprogram instantiation, omit instantiations of
- -- intrinsic operations (Unchecked_Conversions, etc.) that
- -- have no bodies.
+ -- For a subprogram instantiation, omit instantiations intrinsic
+ -- operations (Unchecked_Conversions, etc.) that have no bodies.
elsif Nkind_In (Decl, N_Function_Instantiation,
N_Procedure_Instantiation)
Collect_Previous_Instances
(Private_Declarations (Specification (Decl)));
- elsif Nkind (Decl) = N_Package_Body then
+ elsif Nkind (Decl) = N_Package_Body
+ and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
+ then
Collect_Previous_Instances (Declarations (Decl));
end if;
and then Nkind (True_Parent) /= N_Compilation_Unit
loop
if Nkind (True_Parent) = N_Package_Declaration
- and then
- Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
+ and then
+ Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
then
-- Parent is a compilation unit that is an instantiation.
-- Instantiation node has been replaced with package decl.
Set_Unit (Parent (True_Parent), Inst_Node);
end if;
- -- Now complete instantiation of enclosing body, if it appears
- -- in some other unit. If it appears in the current unit, the
- -- body will have been instantiated already.
+ -- Now complete instantiation of enclosing body, if it appears in
+ -- some other unit. If it appears in the current unit, the body
+ -- will have been instantiated already.
if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
Scop := Scope (Scop);
end loop;
- -- Collect previous instantiations in the unit that
- -- contains the desired generic.
+ -- Collect previous instantiations in the unit that contains
+ -- the desired generic.
if Nkind (Parent (True_Parent)) /= N_Compilation_Unit
and then not Body_Optional
(Private_Declarations (Specification (Par)));
else
- -- Enclosing unit is a subprogram body, In this
+ -- Enclosing unit is a subprogram body. In this
-- case all instance bodies are processed in order
-- and there is no need to collect them separately.
end if;
end Load_Parent_Of_Generic;
+ ---------------------------------
+ -- Map_Formal_Package_Entities --
+ ---------------------------------
+
+ procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is
+ E1 : Entity_Id;
+ E2 : Entity_Id;
+
+ 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) and then E1 /= First_Private_Entity (Form) loop
+ -- Could this test be a single condition???
+ -- Seems like it could, and isn't FPE (Form) a constant anyway???
+
+ if not Is_Internal (E1)
+ and then Present (Parent (E1))
+ and then not Is_Class_Wide_Type (E1)
+ and then not Is_Internal_Name (Chars (E1))
+ then
+ while Present (E2) and then Chars (E2) /= Chars (E1) loop
+ Next_Entity (E2);
+ end loop;
+
+ if No (E2) then
+ exit;
+ else
+ Set_Instance_Of (E1, E2);
+
+ if Is_Type (E1) and then Is_Tagged_Type (E2) then
+ Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2));
+ end if;
+
+ if Is_Constrained (E1) then
+ Set_Instance_Of (Base_Type (E1), Base_Type (E2));
+ end if;
+
+ if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then
+ Map_Formal_Package_Entities (E1, E2);
+ end if;
+ end if;
+ end if;
+
+ Next_Entity (E1);
+ end loop;
+ end Map_Formal_Package_Entities;
+
-----------------------
-- Move_Freeze_Nodes --
-----------------------
Spec : Node_Id;
function Is_Outer_Type (T : Entity_Id) return Boolean;
- -- Check whether entity is declared in a scope external to that
- -- of the generic unit.
+ -- Check whether entity is declared in a scope external to that of the
+ -- generic unit.
-------------------
-- Is_Outer_Type --
-- recurse. Nested generic packages will have been processed from the
-- inside out.
- if Nkind (Decl) = N_Package_Declaration then
- Spec := Specification (Decl);
+ case Nkind (Decl) is
+ when N_Package_Declaration =>
+ Spec := Specification (Decl);
- elsif Nkind (Decl) = N_Task_Type_Declaration then
- Spec := Task_Definition (Decl);
+ when N_Task_Type_Declaration =>
+ Spec := Task_Definition (Decl);
- elsif Nkind (Decl) = N_Protected_Type_Declaration then
- Spec := Protected_Definition (Decl);
+ when N_Protected_Type_Declaration =>
+ Spec := Protected_Definition (Decl);
- else
- Spec := Empty;
- end if;
+ when others =>
+ Spec := Empty;
+ end case;
if Present (Spec) then
- Move_Freeze_Nodes (Out_Of, Next_Node,
- Visible_Declarations (Spec));
- Move_Freeze_Nodes (Out_Of, Next_Node,
- Private_Declarations (Spec));
+ Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec));
+ Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec));
end if;
Next (Decl);
Act : Node_Id;
Errs : constant Int := Serious_Errors_Detected;
+ Cur : Entity_Id := Empty;
+ -- Current homograph of the instance name
+
+ Vis : Boolean;
+ -- Saved visibility status of the current homograph
+
begin
Assoc := First (Generic_Associations (N));
+
+ -- If the instance is a child unit, its name may hide an outer homonym,
+ -- so make it invisible to perform name resolution on the actuals.
+
+ if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name
+ and then Present
+ (Current_Entity (Defining_Identifier (Defining_Unit_Name (N))))
+ then
+ Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N)));
+
+ if Is_Compilation_Unit (Cur) then
+ Vis := Is_Immediately_Visible (Cur);
+ Set_Is_Immediately_Visible (Cur, False);
+ else
+ Cur := Empty;
+ end if;
+ end if;
+
while Present (Assoc) loop
if Nkind (Assoc) /= N_Others_Choice then
Act := Explicit_Generic_Actual_Parameter (Assoc);
if Nkind (Expr) = N_Subtype_Indication then
Analyze (Subtype_Mark (Expr));
- -- Analyze separately each discriminant constraint,
- -- when given with a named association.
+ -- Analyze separately each discriminant constraint, when
+ -- given with a named association.
declare
Constr : Node_Id;
Set_Is_Instantiated (Entity (Name (N)));
end if;
+ if Present (Cur) then
+
+ -- For the case of a child instance hiding an outer homonym,
+ -- provide additional warning which might explain the error.
+
+ Set_Is_Immediately_Visible (Cur, Vis);
+ Error_Msg_NE ("& hides outer unit with the same name?",
+ N, Defining_Unit_Name (N));
+ end if;
+
Abandon_Instantiation (Act);
end if;
end if;
Next (Assoc);
end loop;
+
+ if Present (Cur) then
+ Set_Is_Immediately_Visible (Cur, Vis);
+ end if;
end Preanalyze_Actuals;
-------------------
procedure Remove_Parent (In_Body : Boolean := False) is
S : Entity_Id := Current_Scope;
- -- S is the scope containing the instantiation just completed. The
- -- scope stack contains the parent instances of the instantiation,
- -- followed by the original S.
+ -- S is the scope containing the instantiation just completed. The scope
+ -- stack contains the parent instances of the instantiation, followed by
+ -- the original S.
E : Entity_Id;
P : Entity_Id;
and then P /= Current_Scope
then
-- We are within an instance of some sibling. Retain
- -- visibility of parent, for proper subsequent cleanup,
- -- and reinstall private declarations as well.
+ -- visibility of parent, for proper subsequent cleanup, and
+ -- reinstall private declarations as well.
Set_In_Private_Part (P);
Install_Private_Declarations (P);
end if;
-- If the ultimate parent is a top-level unit recorded in
- -- Instance_Parent_Unit, then reset its visibility to what
- -- it was before instantiation. (It's not clear what the
- -- purpose is of testing whether Scope (P) is In_Open_Scopes,
- -- but that test was present before the ultimate parent test
- -- was added.???)
+ -- Instance_Parent_Unit, then reset its visibility to what is was
+ -- before instantiation. (It's not clear what the purpose is of
+ -- testing whether Scope (P) is In_Open_Scopes, but that test was
+ -- present before the ultimate parent test was added.???)
elsif not In_Open_Scopes (Scope (P))
or else (P = Instance_Parent_Unit
Set_Is_Immediately_Visible (P, False);
-- If the current scope is itself an instantiation of a generic
- -- nested within P, and we are in the private part of body of
- -- this instantiation, restore the full views of P, that were
- -- removed in End_Package_Scope above. This obscure case can
- -- occur when a subunit of a generic contains an instance of
- -- of a child unit of its generic parent unit.
-
- elsif S = Current_Scope
- and then Is_Generic_Instance (S)
- then
+ -- nested within P, and we are in the private part of body of this
+ -- instantiation, restore the full views of P, that were removed
+ -- in End_Package_Scope above. This obscure case can occur when a
+ -- subunit of a generic contains an instance of a child unit of
+ -- its generic parent unit.
+
+ elsif S = Current_Scope and then Is_Generic_Instance (S) then
declare
Par : constant Entity_Id :=
Generic_Parent
end loop;
else
- -- Each body is analyzed separately, and there is no context
- -- that needs preserving from one body instance to the next,
- -- so remove all parent scopes that have been installed.
+ -- Each body is analyzed separately, and there is no context that
+ -- needs preserving from one body instance to the next, so remove all
+ -- parent scopes that have been installed.
while Present (S) loop
End_Package_Scope (S);
begin
if No (Current_Instantiated_Parent.Act_Id) then
-
-- Restore environment after subprogram inlining
Restore_Private_Views (Empty);
Dep_Typ : Node_Id;
procedure Restore_Nested_Formal (Formal : Entity_Id);
- -- Hide the generic formals of formal packages declared with box
- -- which were reachable in the current instantiation.
+ -- Hide the generic formals of formal packages declared with box which
+ -- were reachable in the current instantiation.
---------------------------
-- Restore_Nested_Formal --
-- Subtypes of types whose views have been exchanged, and that
-- are defined within the instance, were not on the list of
- -- Private_Dependents on entry to the instance, so they have to
- -- be exchanged explicitly now, in order to remain consistent with
- -- the view of the parent type.
+ -- Private_Dependents on entry to the instance, so they have to be
+ -- exchanged explicitly now, in order to remain consistent with the
+ -- view of the parent type.
if Ekind (Typ) = E_Private_Type
or else Ekind (Typ) = E_Limited_Private_Type
return;
end if;
- -- Make the generic formal parameters private, and make the formal
- -- types into subtypes of the actuals again.
+ -- Make the generic formal parameters private, and make the formal types
+ -- into subtypes of the actuals again.
E := First_Entity (Pack_Id);
while Present (E) loop
elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
null;
- elsif Denotes_Formal_Package (Renamed_Object (E), True) then
+ elsif
+ Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id)
+ then
Set_Is_Hidden (E, False);
else
-- the time the instantiations will be analyzed.
procedure Reset_Entity (N : Node_Id);
- -- Save semantic information on global entity, so that it is not
- -- resolved again at instantiation time.
+ -- 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
function Is_Instance_Node (Decl : Node_Id) return Boolean is
begin
- return (Nkind (Decl) in N_Generic_Instantiation
- or else
- Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration);
+ return Nkind (Decl) in N_Generic_Instantiation
+ or else
+ Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration;
end Is_Instance_Node;
-- Start of processing for Is_Global
procedure Reset_Entity (N : Node_Id) is
procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
- -- If the type of N2 is global to the generic unit. Save
- -- the type in the generic node.
+ -- If the type of N2 is global to the generic unit. Save the type in
+ -- the generic node.
+ -- What does this comment mean???
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.
+ -- 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 --
if Entity (N) /= N2
and then Has_Private_View (Entity (N))
then
- -- If the entity of N is not the associated node, this is
- -- a nested generic and it has an associated node as well,
- -- whose type is already the full view (see below). Indicate
- -- that the original node has a private view.
+ -- If the entity of N is not the associated node, this is a
+ -- nested generic and it has an associated node as well, whose
+ -- type is already the full view (see below). Indicate that the
+ -- original node has a private view.
Set_Has_Private_View (N);
end if;
Set_Has_Private_View (N);
end if;
- -- If it is a derivation of a private type in a context where
- -- no full view is needed, nothing to do either.
+ -- If it is a derivation of a private type in a context where no
+ -- full view is needed, nothing to do either.
elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
null;
- -- Otherwise mark the type for flipping and use the full_view
- -- when available.
+ -- Otherwise mark the type for flipping and use the full view when
+ -- available.
else
Set_Has_Private_View (N);
-- 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.
+ -- generic itself because it may be hidden by a local declaration.
elsif In_Open_Scopes (Entity (Parent (N2)))
and then not
-- A selected component may denote a static constant that has been
-- folded. If the static constant is global to the generic, capture
- -- its value. Otherwise the folding will happen in any instantiation,
+ -- its value. Otherwise the folding will happen in any instantiation.
elsif Nkind (Parent (N)) = N_Selected_Component
and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal)
-- Save_References --
---------------------
- -- This is the recursive procedure that does the work, once the
- -- enclosing generic scope has been established. We have to treat
- -- specially a number of node rewritings that are required by semantic
- -- processing and which change the kind of nodes in the generic copy:
- -- typically constant-folding, replacing an operator node by a string
- -- literal, or a selected component by an expanded name. In each of
- -- those cases, the transformation is propagated to the generic unit.
+ -- This is the recursive procedure that does the work once the enclosing
+ -- generic scope has been established. We have to treat specially a
+ -- number of node rewritings that are required by semantic processing
+ -- and which change the kind of nodes in the generic copy: typically
+ -- constant-folding, replacing an operator node by a string literal, or
+ -- a selected component by an expanded name. In each of those cases, the
+ -- transformation is propagated to the generic unit.
procedure Save_References (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
begin
if N = Empty then
null;
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
+ -- retain the entity to avoid spurious ambiguities if it is
-- overloaded at the point of instantiation or inlining.
Rewrite (N, New_Copy (N2));
elsif Nkind (N2) = N_Explicit_Dereference then
- -- An identifier is rewritten as a dereference if it is
- -- the prefix in a selected component, and it denotes an
- -- access to a composite type, or a parameterless function
- -- call that returns an access type.
+ -- An identifier is rewritten as a dereference if it is the
+ -- prefix in an implicit dereference.
-- Check whether corresponding entity in prefix is global
and then Is_Global (Entity (Prefix (N2)))
then
Rewrite (N,
- Make_Explicit_Dereference (Sloc (N),
- Prefix => Make_Identifier (Sloc (N),
- Chars => Chars (N))));
- Set_Associated_Node (Prefix (N), Prefix (N2));
-
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Entity (Prefix (N2)), Loc)));
elsif Nkind (Prefix (N2)) = N_Function_Call
and then Is_Global (Entity (Name (Prefix (N2))))
then
Rewrite (N,
- Make_Explicit_Dereference (Sloc (N),
- Prefix => Make_Function_Call (Sloc (N),
- Name =>
- Make_Identifier (Sloc (N),
- Chars => Chars (N)))));
-
- Set_Associated_Node
- (Name (Prefix (N)), Name (Prefix (N2)));
+ Make_Explicit_Dereference (Loc,
+ Prefix => Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (Name (Prefix (N2))),
+ Loc))));
else
Set_Associated_Node (N, Empty);
else
declare
- Loc : constant Source_Ptr := Sloc (N);
Qual : Node_Id := Empty;
Typ : Entity_Id := Empty;
Nam : Node_Id;
OSDN Git Service
