sem_ch12.adb (Instantiate_Subprogram_Body): When creating the defining entity for the instance body...
2005-09-01 Ed Schonberg <schonberg@adacore.com> Javier Miranda <miranda@adacore.com> Gary Dismukes <dismukes@adacore.com> * sem_ch12.adb (Instantiate_Subprogram_Body): When creating the defining entity for the instance body, make a new defining identifier rather than copying the entity of the spec, to prevent accidental sharing of the entity list. (Check_Private_View): When exchanging views of private types, build the list of exchanged views as a stack, to ensure that on exit the exchanges are undone in the proper order. (Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation): Restore the compilation environment in case of instantiation_error. (Analyze_Generic_Subprogram_Declaration): Handle creation of type entity for an anonymous access result. (Instantiate_Generic_Subprogram): Subtype_Mark => Result_Definition (Formal_Entity): Handle properly the case of a formal package that denotes a generic package renaming. From-SVN: r103879
This commit is contained in:
parent
f818564703
commit
48aa1f1a61
|
@ -33,7 +33,6 @@ with Fname; use Fname;
|
||||||
with Fname.UF; use Fname.UF;
|
with Fname.UF; use Fname.UF;
|
||||||
with Freeze; use Freeze;
|
with Freeze; use Freeze;
|
||||||
with Hostparm;
|
with Hostparm;
|
||||||
with Inline; use Inline;
|
|
||||||
with Lib; use Lib;
|
with Lib; use Lib;
|
||||||
with Lib.Load; use Lib.Load;
|
with Lib.Load; use Lib.Load;
|
||||||
with Lib.Xref; use Lib.Xref;
|
with Lib.Xref; use Lib.Xref;
|
||||||
|
@ -2240,6 +2239,7 @@ package body Sem_Ch12 is
|
||||||
Id : Entity_Id;
|
Id : Entity_Id;
|
||||||
Formals : List_Id;
|
Formals : List_Id;
|
||||||
New_N : Node_Id;
|
New_N : Node_Id;
|
||||||
|
Result_Type : Entity_Id;
|
||||||
Save_Parent : Node_Id;
|
Save_Parent : Node_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -2283,17 +2283,23 @@ package body Sem_Ch12 is
|
||||||
|
|
||||||
if Nkind (Spec) = N_Function_Specification then
|
if Nkind (Spec) = N_Function_Specification then
|
||||||
Set_Ekind (Id, E_Generic_Function);
|
Set_Ekind (Id, E_Generic_Function);
|
||||||
Find_Type (Subtype_Mark (Spec));
|
|
||||||
Set_Etype (Id, Entity (Subtype_Mark (Spec)));
|
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
|
||||||
|
Result_Type := Access_Definition (Spec, Result_Definition (Spec));
|
||||||
|
Set_Etype (Id, Result_Type);
|
||||||
|
else
|
||||||
|
Find_Type (Result_Definition (Spec));
|
||||||
|
Set_Etype (Id, Entity (Result_Definition (Spec)));
|
||||||
|
end if;
|
||||||
|
|
||||||
else
|
else
|
||||||
Set_Ekind (Id, E_Generic_Procedure);
|
Set_Ekind (Id, E_Generic_Procedure);
|
||||||
Set_Etype (Id, Standard_Void_Type);
|
Set_Etype (Id, Standard_Void_Type);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- For a library unit, we have reconstructed the entity for the
|
-- For a library unit, we have reconstructed the entity for the unit,
|
||||||
-- unit, and must reset it in the library tables. We also need
|
-- and must reset it in the library tables. We also make sure that
|
||||||
-- to make sure that Body_Required is set properly in the original
|
-- Body_Required is set properly in the original compilation unit node.
|
||||||
-- compilation unit node.
|
|
||||||
|
|
||||||
if Nkind (Parent (N)) = N_Compilation_Unit then
|
if Nkind (Parent (N)) = N_Compilation_Unit then
|
||||||
Set_Cunit_Entity (Current_Sem_Unit, Id);
|
Set_Cunit_Entity (Current_Sem_Unit, Id);
|
||||||
|
@ -2315,9 +2321,9 @@ package body Sem_Ch12 is
|
||||||
-- Analyze_Package_Instantiation --
|
-- Analyze_Package_Instantiation --
|
||||||
-----------------------------------
|
-----------------------------------
|
||||||
|
|
||||||
-- Note: this procedure is also used for formal package declarations,
|
-- Note: this procedure is also used for formal package declarations, in
|
||||||
-- in which case the argument N is an N_Formal_Package_Declaration
|
-- which case the argument N is an N_Formal_Package_Declaration node.
|
||||||
-- node. This should really be noted in the spec! ???
|
-- This should really be noted in the spec! ???
|
||||||
|
|
||||||
procedure Analyze_Package_Instantiation (N : Node_Id) is
|
procedure Analyze_Package_Instantiation (N : Node_Id) is
|
||||||
Loc : constant Source_Ptr := Sloc (N);
|
Loc : constant Source_Ptr := Sloc (N);
|
||||||
|
@ -2335,6 +2341,7 @@ package body Sem_Ch12 is
|
||||||
Is_Actual_Pack : constant Boolean :=
|
Is_Actual_Pack : constant Boolean :=
|
||||||
Is_Internal (Defining_Entity (N));
|
Is_Internal (Defining_Entity (N));
|
||||||
|
|
||||||
|
Env_Installed : Boolean := False;
|
||||||
Parent_Installed : Boolean := False;
|
Parent_Installed : Boolean := False;
|
||||||
Renaming_List : List_Id;
|
Renaming_List : List_Id;
|
||||||
Unit_Renaming : Node_Id;
|
Unit_Renaming : Node_Id;
|
||||||
|
@ -2428,6 +2435,7 @@ package body Sem_Ch12 is
|
||||||
Pre_Analyze_Actuals (N);
|
Pre_Analyze_Actuals (N);
|
||||||
|
|
||||||
Init_Env;
|
Init_Env;
|
||||||
|
Env_Installed := True;
|
||||||
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
|
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
|
||||||
Gen_Unit := Entity (Gen_Id);
|
Gen_Unit := Entity (Gen_Id);
|
||||||
|
|
||||||
|
@ -2900,6 +2908,7 @@ package body Sem_Ch12 is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Restore_Env;
|
Restore_Env;
|
||||||
|
Env_Installed := False;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Validate_Categorization_Dependency (N, Act_Decl_Id);
|
Validate_Categorization_Dependency (N, Act_Decl_Id);
|
||||||
|
@ -2933,6 +2942,10 @@ package body Sem_Ch12 is
|
||||||
if Parent_Installed then
|
if Parent_Installed then
|
||||||
Remove_Parent;
|
Remove_Parent;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
if Env_Installed then
|
||||||
|
Restore_Env;
|
||||||
|
end if;
|
||||||
end Analyze_Package_Instantiation;
|
end Analyze_Package_Instantiation;
|
||||||
|
|
||||||
--------------------------
|
--------------------------
|
||||||
|
@ -3188,6 +3201,7 @@ package body Sem_Ch12 is
|
||||||
Act_Spec : Node_Id;
|
Act_Spec : Node_Id;
|
||||||
Act_Tree : Node_Id;
|
Act_Tree : Node_Id;
|
||||||
|
|
||||||
|
Env_Installed : Boolean := False;
|
||||||
Gen_Unit : Entity_Id;
|
Gen_Unit : Entity_Id;
|
||||||
Gen_Decl : Node_Id;
|
Gen_Decl : Node_Id;
|
||||||
Pack_Id : Entity_Id;
|
Pack_Id : Entity_Id;
|
||||||
|
@ -3364,6 +3378,7 @@ package body Sem_Ch12 is
|
||||||
Pre_Analyze_Actuals (N);
|
Pre_Analyze_Actuals (N);
|
||||||
|
|
||||||
Init_Env;
|
Init_Env;
|
||||||
|
Env_Installed := True;
|
||||||
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
|
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
|
||||||
Gen_Unit := Entity (Gen_Id);
|
Gen_Unit := Entity (Gen_Id);
|
||||||
|
|
||||||
|
@ -3598,6 +3613,7 @@ package body Sem_Ch12 is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Restore_Env;
|
Restore_Env;
|
||||||
|
Env_Installed := False;
|
||||||
Generic_Renamings.Set_Last (0);
|
Generic_Renamings.Set_Last (0);
|
||||||
Generic_Renamings_HTable.Reset;
|
Generic_Renamings_HTable.Reset;
|
||||||
end if;
|
end if;
|
||||||
|
@ -3607,6 +3623,10 @@ package body Sem_Ch12 is
|
||||||
if Parent_Installed then
|
if Parent_Installed then
|
||||||
Remove_Parent;
|
Remove_Parent;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
if Env_Installed then
|
||||||
|
Restore_Env;
|
||||||
|
end if;
|
||||||
end Analyze_Subprogram_Instantiation;
|
end Analyze_Subprogram_Instantiation;
|
||||||
|
|
||||||
-------------------------
|
-------------------------
|
||||||
|
@ -4599,7 +4619,7 @@ package body Sem_Ch12 is
|
||||||
elsif Nkind (Parent (N)) = N_Subtype_Declaration
|
elsif Nkind (Parent (N)) = N_Subtype_Declaration
|
||||||
or else not In_Private_Part (Scope (Base_Type (T)))
|
or else not In_Private_Part (Scope (Base_Type (T)))
|
||||||
then
|
then
|
||||||
Append_Elmt (T, Exchanged_Views);
|
Prepend_Elmt (T, Exchanged_Views);
|
||||||
Exchange_Declarations (Etype (Get_Associated_Node (N)));
|
Exchange_Declarations (Etype (Get_Associated_Node (N)));
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -4640,7 +4660,7 @@ package body Sem_Ch12 is
|
||||||
and then not Is_Generic_Type (BT)
|
and then not Is_Generic_Type (BT)
|
||||||
and then not In_Open_Scopes (BT)
|
and then not In_Open_Scopes (BT)
|
||||||
then
|
then
|
||||||
Append_Elmt (Full_View (BT), Exchanged_Views);
|
Prepend_Elmt (Full_View (BT), Exchanged_Views);
|
||||||
Exchange_Declarations (BT);
|
Exchange_Declarations (BT);
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
@ -6542,14 +6562,25 @@ package body Sem_Ch12 is
|
||||||
Formal_Node : Node_Id;
|
Formal_Node : Node_Id;
|
||||||
Formal_Ent : Entity_Id;
|
Formal_Ent : Entity_Id;
|
||||||
|
|
||||||
Gen_Decl : constant Node_Id :=
|
Gen_Decl : Node_Id;
|
||||||
Unit_Declaration_Node
|
Formals : List_Id;
|
||||||
(Entity (Name (Orig_Node)));
|
|
||||||
|
|
||||||
Formals : constant List_Id :=
|
|
||||||
Generic_Formal_Declarations (Gen_Decl);
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
-- The actual may be a renamed generic package, in which
|
||||||
|
-- case we want to retrieve the original generic in order
|
||||||
|
-- to traverse its formal part.
|
||||||
|
|
||||||
|
if Present (Renamed_Entity (Entity (Name (Orig_Node)))) then
|
||||||
|
Gen_Decl :=
|
||||||
|
Unit_Declaration_Node (
|
||||||
|
Renamed_Entity (Entity (Name (Orig_Node))));
|
||||||
|
else
|
||||||
|
Gen_Decl :=
|
||||||
|
Unit_Declaration_Node (Entity (Name (Orig_Node)));
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Formals := Generic_Formal_Declarations (Gen_Decl);
|
||||||
|
|
||||||
if Present (Formals) then
|
if Present (Formals) then
|
||||||
Formal_Node := First_Non_Pragma (Formals);
|
Formal_Node := First_Non_Pragma (Formals);
|
||||||
else
|
else
|
||||||
|
@ -7260,7 +7291,7 @@ package body Sem_Ch12 is
|
||||||
|
|
||||||
Prepend (Subt_Decl, List);
|
Prepend (Subt_Decl, List);
|
||||||
|
|
||||||
Append_Elmt (Full_View (Ftyp), Exchanged_Views);
|
Prepend_Elmt (Full_View (Ftyp), Exchanged_Views);
|
||||||
Exchange_Declarations (Ftyp);
|
Exchange_Declarations (Ftyp);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -7834,7 +7865,8 @@ package body Sem_Ch12 is
|
||||||
Make_Subprogram_Body (Loc,
|
Make_Subprogram_Body (Loc,
|
||||||
Specification =>
|
Specification =>
|
||||||
Make_Procedure_Specification (Loc,
|
Make_Procedure_Specification (Loc,
|
||||||
Defining_Unit_Name => New_Copy (Anon_Id),
|
Defining_Unit_Name =>
|
||||||
|
Make_Defining_Identifier (Loc, Chars (Anon_Id)),
|
||||||
Parameter_Specifications =>
|
Parameter_Specifications =>
|
||||||
New_Copy_List
|
New_Copy_List
|
||||||
(Parameter_Specifications (Parent (Anon_Id)))),
|
(Parameter_Specifications (Parent (Anon_Id)))),
|
||||||
|
@ -7860,11 +7892,12 @@ package body Sem_Ch12 is
|
||||||
Make_Subprogram_Body (Loc,
|
Make_Subprogram_Body (Loc,
|
||||||
Specification =>
|
Specification =>
|
||||||
Make_Function_Specification (Loc,
|
Make_Function_Specification (Loc,
|
||||||
Defining_Unit_Name => New_Copy (Anon_Id),
|
Defining_Unit_Name =>
|
||||||
|
Make_Defining_Identifier (Loc, Chars (Anon_Id)),
|
||||||
Parameter_Specifications =>
|
Parameter_Specifications =>
|
||||||
New_Copy_List
|
New_Copy_List
|
||||||
(Parameter_Specifications (Parent (Anon_Id))),
|
(Parameter_Specifications (Parent (Anon_Id))),
|
||||||
Subtype_Mark =>
|
Result_Definition =>
|
||||||
New_Occurrence_Of (Etype (Anon_Id), Loc)),
|
New_Occurrence_Of (Etype (Anon_Id), Loc)),
|
||||||
|
|
||||||
Declarations => Empty_List,
|
Declarations => Empty_List,
|
||||||
|
@ -10165,7 +10198,7 @@ package body Sem_Ch12 is
|
||||||
Priv_Elmt := First_Elmt (Private_Dependents (BT));
|
Priv_Elmt := First_Elmt (Private_Dependents (BT));
|
||||||
|
|
||||||
if Present (Full_View (BT)) then
|
if Present (Full_View (BT)) then
|
||||||
Append_Elmt (Full_View (BT), Exchanged_Views);
|
Prepend_Elmt (Full_View (BT), Exchanged_Views);
|
||||||
Exchange_Declarations (BT);
|
Exchange_Declarations (BT);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -10184,7 +10217,7 @@ package body Sem_Ch12 is
|
||||||
if Present (Full_View (Priv_Sub))
|
if Present (Full_View (Priv_Sub))
|
||||||
and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
|
and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
|
||||||
then
|
then
|
||||||
Append_Elmt (Full_View (Priv_Sub), Exchanged_Views);
|
Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views);
|
||||||
Exchange_Declarations (Priv_Sub);
|
Exchange_Declarations (Priv_Sub);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue