[multiple changes]
2011-10-24 Emmanuel Briot <briot@adacore.com> * prj-proc.adb (Process_Expression_Variable_Decl): No special handling for Project_Path unless it is an attribute. 2011-10-24 Javier Miranda <miranda@adacore.com> * sem_ch12.adb (Check_Hidden_Primitives): New subprogram. (Install_Hidden_Primitives): New subprogram. (Restore_Hidden_Primitives): New subprogram. (Analyze_Formal_Package_Declaration, Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation): Invoke Check_Hidden_Primitives after every call to Analyze_Associations, and invoke Restore_Hidden_Primitives to restore their visibility after processing the instantiation. (Instantiate_Package_Body): Install visible primitives before analyzing the instantiation and uninstall them to restore their visibility when the instantiation has been analyzed. * sem_util.ads, sem_util.adb (Add_Suffix): New subprogram (Remove_Suffix): New subprogram * sem_ch3.adb (Derive_Subprogram): When handling a derived subprogram for the instantiation of a formal derived tagged type, inherit the dispatching attributes from the actual subprogram (not from the parent type). From-SVN: r180370
This commit is contained in:
Arnaud Charlet
parent
db4b3c499d
commit
292689c213
6 changed files with 319 additions and 16 deletions
|
|
@ -1,3 +1,28 @@
|
|||
2011-10-24 Emmanuel Briot <briot@adacore.com>
|
||||
|
||||
* prj-proc.adb (Process_Expression_Variable_Decl): No special
|
||||
handling for Project_Path unless it is an attribute.
|
||||
|
||||
2011-10-24 Javier Miranda <miranda@adacore.com>
|
||||
|
||||
* sem_ch12.adb (Check_Hidden_Primitives): New subprogram.
|
||||
(Install_Hidden_Primitives): New subprogram.
|
||||
(Restore_Hidden_Primitives): New subprogram.
|
||||
(Analyze_Formal_Package_Declaration,
|
||||
Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation):
|
||||
Invoke Check_Hidden_Primitives after every call to
|
||||
Analyze_Associations, and invoke Restore_Hidden_Primitives to
|
||||
restore their visibility after processing the instantiation.
|
||||
(Instantiate_Package_Body): Install visible primitives before
|
||||
analyzing the instantiation and uninstall them to restore their
|
||||
visibility when the instantiation has been analyzed.
|
||||
* sem_util.ads, sem_util.adb (Add_Suffix): New subprogram
|
||||
(Remove_Suffix): New subprogram
|
||||
* sem_ch3.adb (Derive_Subprogram): When handling
|
||||
a derived subprogram for the instantiation of a formal derived
|
||||
tagged type, inherit the dispatching attributes from the actual
|
||||
subprogram (not from the parent type).
|
||||
|
||||
2011-10-24 Vasiliy Fofanov <fofanov@adacore.com>
|
||||
|
||||
* gnat_ugn.texi: Document explicit use of XDECGNAT library.
|
||||
|
|
|
|||
|
|
@ -2053,7 +2053,7 @@ package body Prj.Proc is
|
|||
Shared.Variable_Elements.Table (Var).Value := New_Value;
|
||||
end if;
|
||||
|
||||
if Name = Snames.Name_Project_Path then
|
||||
if Is_Attribute and then Name = Snames.Name_Project_Path then
|
||||
if In_Tree.Is_Root_Tree then
|
||||
declare
|
||||
Val : String_List_Id := New_Value.Values;
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ with Einfo; use Einfo;
|
|||
with Elists; use Elists;
|
||||
with Errout; use Errout;
|
||||
with Expander; use Expander;
|
||||
with Exp_Disp; use Exp_Disp;
|
||||
with Fname; use Fname;
|
||||
with Fname.UF; use Fname.UF;
|
||||
with Freeze; use Freeze;
|
||||
|
|
@ -399,6 +400,13 @@ package body Sem_Ch12 is
|
|||
-- package cannot be inlined by the front-end because front-end inlining
|
||||
-- requires a strict linear order of elaboration.
|
||||
|
||||
function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id;
|
||||
-- Check if some association between formals and actuals requires to make
|
||||
-- visible primitives of a tagged type, and make those primitives visible.
|
||||
-- Return the list of primitives whose visibility is modified (to restore
|
||||
-- their visibility later through Restore_Hidden_Primitives). If no
|
||||
-- candidate is found then return No_Elist.
|
||||
|
||||
procedure Check_Hidden_Child_Unit
|
||||
(N : Node_Id;
|
||||
Gen_Unit : Entity_Id;
|
||||
|
|
@ -556,6 +564,18 @@ package body Sem_Ch12 is
|
|||
procedure Remove_Parent (In_Body : Boolean := False);
|
||||
-- Reverse effect after instantiation of child is complete
|
||||
|
||||
procedure Install_Hidden_Primitives
|
||||
(Prims_List : in out Elist_Id;
|
||||
Gen_T : Entity_Id;
|
||||
Act_T : Entity_Id);
|
||||
-- Remove suffix 'P' from hidden primitives of Act_T to match the
|
||||
-- visibility of primitives of Gen_T. The list of primitives to which
|
||||
-- the suffix is removed is added to Prims_List to restore them later.
|
||||
|
||||
procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id);
|
||||
-- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
|
||||
-- set to No_Elist.
|
||||
|
||||
procedure Inline_Instance_Body
|
||||
(N : Node_Id;
|
||||
Gen_Unit : Entity_Id;
|
||||
|
|
@ -884,7 +904,6 @@ package body Sem_Ch12 is
|
|||
Formals : List_Id;
|
||||
F_Copy : List_Id) return List_Id
|
||||
is
|
||||
|
||||
Actual_Types : constant Elist_Id := New_Elmt_List;
|
||||
Assoc : constant List_Id := New_List;
|
||||
Default_Actuals : constant Elist_Id := New_Elmt_List;
|
||||
|
|
@ -2039,6 +2058,10 @@ package body Sem_Ch12 is
|
|||
Renaming_In_Par : Entity_Id;
|
||||
Associations : Boolean := True;
|
||||
|
||||
Vis_Prims_List : Elist_Id := No_Elist;
|
||||
-- List of primitives made temporarily visible in the instantiation
|
||||
-- to match the visibility of the formal type
|
||||
|
||||
function Build_Local_Package return Node_Id;
|
||||
-- The formal package is rewritten so that its parameters are replaced
|
||||
-- with corresponding declarations. For parameters with bona fide
|
||||
|
|
@ -2124,9 +2147,11 @@ package body Sem_Ch12 is
|
|||
|
||||
Decls :=
|
||||
Analyze_Associations
|
||||
(Original_Node (N),
|
||||
Generic_Formal_Declarations (Act_Tree),
|
||||
Generic_Formal_Declarations (Gen_Decl));
|
||||
(I_Node => Original_Node (N),
|
||||
Formals => Generic_Formal_Declarations (Act_Tree),
|
||||
F_Copy => Generic_Formal_Declarations (Gen_Decl));
|
||||
|
||||
Vis_Prims_List := Check_Hidden_Primitives (Decls);
|
||||
end;
|
||||
end if;
|
||||
|
||||
|
|
@ -2263,6 +2288,7 @@ package body Sem_Ch12 is
|
|||
Enter_Name (Formal);
|
||||
Set_Ekind (Formal, E_Variable);
|
||||
Set_Etype (Formal, Any_Type);
|
||||
Restore_Hidden_Primitives (Vis_Prims_List);
|
||||
|
||||
if Parent_Installed then
|
||||
Remove_Parent;
|
||||
|
|
@ -2336,6 +2362,7 @@ package body Sem_Ch12 is
|
|||
end;
|
||||
|
||||
End_Package_Scope (Formal);
|
||||
Restore_Hidden_Primitives (Vis_Prims_List);
|
||||
|
||||
if Parent_Installed then
|
||||
Remove_Parent;
|
||||
|
|
@ -3131,6 +3158,12 @@ package body Sem_Ch12 is
|
|||
return False;
|
||||
end Might_Inline_Subp;
|
||||
|
||||
-- Local declarations
|
||||
|
||||
Vis_Prims_List : Elist_Id := No_Elist;
|
||||
-- List of primitives made temporarily visible in the instantiation
|
||||
-- to match the visibility of the formal type
|
||||
|
||||
-- Start of processing for Analyze_Package_Instantiation
|
||||
|
||||
begin
|
||||
|
|
@ -3308,9 +3341,11 @@ package body Sem_Ch12 is
|
|||
|
||||
Renaming_List :=
|
||||
Analyze_Associations
|
||||
(N,
|
||||
Generic_Formal_Declarations (Act_Tree),
|
||||
Generic_Formal_Declarations (Gen_Decl));
|
||||
(I_Node => N,
|
||||
Formals => Generic_Formal_Declarations (Act_Tree),
|
||||
F_Copy => Generic_Formal_Declarations (Gen_Decl));
|
||||
|
||||
Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
|
||||
|
||||
Set_Instance_Env (Gen_Unit, Act_Decl_Id);
|
||||
Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
|
||||
|
|
@ -3696,6 +3731,7 @@ package body Sem_Ch12 is
|
|||
|
||||
Check_Formal_Packages (Act_Decl_Id);
|
||||
|
||||
Restore_Hidden_Primitives (Vis_Prims_List);
|
||||
Restore_Private_Views (Act_Decl_Id);
|
||||
|
||||
Inherit_Context (Gen_Decl, N);
|
||||
|
|
@ -4277,6 +4313,12 @@ package body Sem_Ch12 is
|
|||
end if;
|
||||
end Analyze_Instance_And_Renamings;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Vis_Prims_List : Elist_Id := No_Elist;
|
||||
-- List of primitives made temporarily visible in the instantiation
|
||||
-- to match the visibility of the formal type
|
||||
|
||||
-- Start of processing for Analyze_Subprogram_Instantiation
|
||||
|
||||
begin
|
||||
|
|
@ -4376,6 +4418,7 @@ package body Sem_Ch12 is
|
|||
Error_Msg_NE
|
||||
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
|
||||
Circularity_Detected := True;
|
||||
Restore_Hidden_Primitives (Vis_Prims_List);
|
||||
goto Leave;
|
||||
end if;
|
||||
|
||||
|
|
@ -4402,9 +4445,11 @@ package body Sem_Ch12 is
|
|||
|
||||
Renaming_List :=
|
||||
Analyze_Associations
|
||||
(N,
|
||||
Generic_Formal_Declarations (Act_Tree),
|
||||
Generic_Formal_Declarations (Gen_Decl));
|
||||
(I_Node => N,
|
||||
Formals => Generic_Formal_Declarations (Act_Tree),
|
||||
F_Copy => Generic_Formal_Declarations (Gen_Decl));
|
||||
|
||||
Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
|
||||
|
||||
-- The subprogram itself cannot contain a nested instance, so the
|
||||
-- current parent is left empty.
|
||||
|
|
@ -4554,6 +4599,7 @@ package body Sem_Ch12 is
|
|||
Remove_Parent;
|
||||
end if;
|
||||
|
||||
Restore_Hidden_Primitives (Vis_Prims_List);
|
||||
Restore_Env;
|
||||
Env_Installed := False;
|
||||
Generic_Renamings.Set_Last (0);
|
||||
|
|
@ -5856,6 +5902,49 @@ package body Sem_Ch12 is
|
|||
end if;
|
||||
end Check_Private_View;
|
||||
|
||||
-----------------------------
|
||||
-- Check_Hidden_Primitives --
|
||||
-----------------------------
|
||||
|
||||
function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is
|
||||
Actual : Node_Id;
|
||||
Gen_T : Entity_Id;
|
||||
Result : Elist_Id := No_Elist;
|
||||
|
||||
begin
|
||||
if No (Assoc_List) then
|
||||
return No_Elist;
|
||||
end if;
|
||||
|
||||
-- Traverse the list of associations between formals and actuals
|
||||
-- searching for renamings of tagged types
|
||||
|
||||
Actual := First (Assoc_List);
|
||||
while Present (Actual) loop
|
||||
if Nkind (Actual) = N_Subtype_Declaration then
|
||||
Gen_T := Generic_Parent_Type (Actual);
|
||||
|
||||
if Present (Gen_T)
|
||||
and then Is_Tagged_Type (Gen_T)
|
||||
then
|
||||
-- Traverse the list of primitives of the actual types
|
||||
-- searching for hidden primitives that are visible in the
|
||||
-- corresponding generic formal; leave them visible and
|
||||
-- append them to Result to restore their decoration later.
|
||||
|
||||
Install_Hidden_Primitives
|
||||
(Prims_List => Result,
|
||||
Gen_T => Gen_T,
|
||||
Act_T => Entity (Subtype_Indication (Actual)));
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Next (Actual);
|
||||
end loop;
|
||||
|
||||
return Result;
|
||||
end Check_Hidden_Primitives;
|
||||
|
||||
--------------------------
|
||||
-- Contains_Instance_Of --
|
||||
--------------------------
|
||||
|
|
@ -7893,6 +7982,138 @@ package body Sem_Ch12 is
|
|||
end if;
|
||||
end Install_Parent;
|
||||
|
||||
-------------------------------
|
||||
-- Install_Hidden_Primitives --
|
||||
-------------------------------
|
||||
|
||||
procedure Install_Hidden_Primitives
|
||||
(Prims_List : in out Elist_Id;
|
||||
Gen_T : Entity_Id;
|
||||
Act_T : Entity_Id)
|
||||
is
|
||||
Elmt : Elmt_Id;
|
||||
List : Elist_Id := No_Elist;
|
||||
Prim_G_Elmt : Elmt_Id;
|
||||
Prim_A_Elmt : Elmt_Id;
|
||||
Prim_G : Node_Id;
|
||||
Prim_A : Node_Id;
|
||||
|
||||
begin
|
||||
-- No action needed in case of serious errors because we cannot trust
|
||||
-- in the order of primitives
|
||||
|
||||
if Serious_Errors_Detected > 0 then
|
||||
return;
|
||||
|
||||
-- No action possible if we don't have available the list of primitive
|
||||
-- operations
|
||||
|
||||
elsif No (Gen_T)
|
||||
or else not Is_Record_Type (Gen_T)
|
||||
or else not Is_Tagged_Type (Gen_T)
|
||||
or else not Is_Record_Type (Act_T)
|
||||
or else not Is_Tagged_Type (Act_T)
|
||||
then
|
||||
return;
|
||||
|
||||
-- There is no need to handle interface types since their primitives
|
||||
-- cannot be hidden
|
||||
|
||||
elsif Is_Interface (Gen_T) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T));
|
||||
|
||||
if not Is_Class_Wide_Type (Act_T) then
|
||||
Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T));
|
||||
else
|
||||
Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T)));
|
||||
end if;
|
||||
|
||||
loop
|
||||
-- Skip predefined primitives in the generic formal
|
||||
|
||||
while Present (Prim_G_Elmt)
|
||||
and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt))
|
||||
loop
|
||||
Next_Elmt (Prim_G_Elmt);
|
||||
end loop;
|
||||
|
||||
-- Skip predefined primitives in the generic actual
|
||||
|
||||
while Present (Prim_A_Elmt)
|
||||
and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt))
|
||||
loop
|
||||
Next_Elmt (Prim_A_Elmt);
|
||||
end loop;
|
||||
|
||||
exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt);
|
||||
|
||||
Prim_G := Node (Prim_G_Elmt);
|
||||
Prim_A := Node (Prim_A_Elmt);
|
||||
|
||||
-- There is no need to handle interface primitives because their
|
||||
-- primitives are not hidden
|
||||
|
||||
exit when Present (Interface_Alias (Prim_G));
|
||||
|
||||
if Chars (Prim_G) /= Chars (Prim_A)
|
||||
and then Has_Suffix (Prim_A, 'P')
|
||||
and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G)
|
||||
then
|
||||
Set_Chars (Prim_A, Chars (Prim_G));
|
||||
|
||||
if List = No_Elist then
|
||||
List := New_Elmt_List;
|
||||
end if;
|
||||
|
||||
Append_Elmt (Prim_A, List);
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim_A_Elmt);
|
||||
Next_Elmt (Prim_G_Elmt);
|
||||
end loop;
|
||||
|
||||
-- Append the elements to the list of temporarily visible primitives
|
||||
-- avoiding duplicates
|
||||
|
||||
if Present (List) then
|
||||
if No (Prims_List) then
|
||||
Prims_List := New_Elmt_List;
|
||||
end if;
|
||||
|
||||
Elmt := First_Elmt (List);
|
||||
while Present (Elmt) loop
|
||||
Append_Unique_Elmt (Node (Elmt), Prims_List);
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
end if;
|
||||
end Install_Hidden_Primitives;
|
||||
|
||||
-------------------------------
|
||||
-- Restore_Hidden_Primitives --
|
||||
-------------------------------
|
||||
|
||||
procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is
|
||||
Prim_Elmt : Elmt_Id;
|
||||
Prim : Node_Id;
|
||||
|
||||
begin
|
||||
if Prims_List /= No_Elist then
|
||||
Prim_Elmt := First_Elmt (Prims_List);
|
||||
|
||||
while Present (Prim_Elmt) loop
|
||||
Prim := Node (Prim_Elmt);
|
||||
Set_Chars (Prim, Add_Suffix (Prim, 'P'));
|
||||
|
||||
Next_Elmt (Prim_Elmt);
|
||||
end loop;
|
||||
|
||||
Prims_List := No_Elist;
|
||||
end if;
|
||||
end Restore_Hidden_Primitives;
|
||||
|
||||
--------------------------------
|
||||
-- Instantiate_Formal_Package --
|
||||
--------------------------------
|
||||
|
|
@ -9065,6 +9286,10 @@ package body Sem_Ch12 is
|
|||
Par_Ent : Entity_Id := Empty;
|
||||
Par_Vis : Boolean := False;
|
||||
|
||||
Vis_Prims_List : Elist_Id := No_Elist;
|
||||
-- List of primitives made temporarily visible in the instantiation
|
||||
-- to match the visibility of the formal type
|
||||
|
||||
begin
|
||||
Gen_Body_Id := Corresponding_Body (Gen_Decl);
|
||||
|
||||
|
|
@ -9134,6 +9359,29 @@ package body Sem_Ch12 is
|
|||
Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
|
||||
Check_Generic_Actuals (Act_Decl_Id, False);
|
||||
|
||||
-- Install primitives hidden at the point of the instantiation but
|
||||
-- visible when processing the generic formals
|
||||
|
||||
declare
|
||||
E : Entity_Id;
|
||||
|
||||
begin
|
||||
E := First_Entity (Act_Decl_Id);
|
||||
while Present (E) loop
|
||||
if Is_Type (E)
|
||||
and then Is_Generic_Actual_Type (E)
|
||||
and then Is_Tagged_Type (E)
|
||||
then
|
||||
Install_Hidden_Primitives
|
||||
(Prims_List => Vis_Prims_List,
|
||||
Gen_T => Generic_Parent_Type (Parent (E)),
|
||||
Act_T => E);
|
||||
end if;
|
||||
|
||||
Next_Entity (E);
|
||||
end loop;
|
||||
end;
|
||||
|
||||
-- If it is a child unit, make the parent instance (which is an
|
||||
-- instance of the parent of the generic) visible. The parent
|
||||
-- instance is the prefix of the name of the generic unit.
|
||||
|
|
@ -9226,6 +9474,7 @@ package body Sem_Ch12 is
|
|||
Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
|
||||
end if;
|
||||
|
||||
Restore_Hidden_Primitives (Vis_Prims_List);
|
||||
Restore_Private_Views (Act_Decl_Id);
|
||||
|
||||
-- Remove the current unit from visibility if this is an instance
|
||||
|
|
|
|||
|
|
@ -13318,18 +13318,18 @@ package body Sem_Ch3 is
|
|||
|
||||
-- Check for case of a derived subprogram for the instantiation of a
|
||||
-- formal derived tagged type, if so mark the subprogram as dispatching
|
||||
-- and inherit the dispatching attributes of the parent subprogram. The
|
||||
-- and inherit the dispatching attributes of the actual subprogram. The
|
||||
-- derived subprogram is effectively renaming of the actual subprogram,
|
||||
-- so it needs to have the same attributes as the actual.
|
||||
|
||||
if Present (Actual_Subp)
|
||||
and then Is_Dispatching_Operation (Parent_Subp)
|
||||
and then Is_Dispatching_Operation (Actual_Subp)
|
||||
then
|
||||
Set_Is_Dispatching_Operation (New_Subp);
|
||||
|
||||
if Present (DTC_Entity (Parent_Subp)) then
|
||||
Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
|
||||
Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
|
||||
if Present (DTC_Entity (Actual_Subp)) then
|
||||
Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
|
||||
Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
|
||||
end if;
|
||||
end if;
|
||||
|
||||
|
|
|
|||
|
|
@ -5965,6 +5965,29 @@ package body Sem_Util is
|
|||
return Name_Buffer (Name_Len) = Suffix;
|
||||
end Has_Suffix;
|
||||
|
||||
----------------
|
||||
-- Add_Suffix --
|
||||
----------------
|
||||
|
||||
function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
|
||||
begin
|
||||
Get_Name_String (Chars (E));
|
||||
Add_Char_To_Name_Buffer (Suffix);
|
||||
return Name_Find;
|
||||
end Add_Suffix;
|
||||
|
||||
-------------------
|
||||
-- Remove_Suffix --
|
||||
-------------------
|
||||
|
||||
function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
|
||||
begin
|
||||
pragma Assert (Has_Suffix (E, Suffix));
|
||||
Get_Name_String (Chars (E));
|
||||
Name_Len := Name_Len - 1;
|
||||
return Name_Find;
|
||||
end Remove_Suffix;
|
||||
|
||||
--------------------------
|
||||
-- Has_Tagged_Component --
|
||||
--------------------------
|
||||
|
|
|
|||
|
|
@ -691,6 +691,12 @@ package Sem_Util is
|
|||
function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean;
|
||||
-- Returns true if the last character of E is Suffix. Used in Assertions.
|
||||
|
||||
function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id;
|
||||
-- Returns the name of E adding Suffix
|
||||
|
||||
function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id;
|
||||
-- Returns the name of E without Suffix
|
||||
|
||||
function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
|
||||
-- Returns True if Typ is a composite type (array or record) which is
|
||||
-- either itself a tagged type, or has a component (recursively) which is
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue