From: Eric Botcazou <ebotcazou@adacore.com>
The main change is the removal of the special bypass for private views in
Resolve_Implicit_Dereference, which in exchange requires additional work
in Check_Generic_Actuals and a couple more calls to Set_Global_Type in
Save_References_In_Identifier. This also removes an unused parameter in
Convert_View and adds a missing comment in Build_Derived_Record_Type.
gcc/ada/
* exp_ch7.adb (Convert_View): Remove Ind parameter and adjust.
* sem_ch12.adb (Check_Generic_Actuals): Check the type of both in
and in out actual objects, as well as the type of formal parameters
of actual subprograms. Extend the condition under which the views
are swapped to nested generic constructs.
(Save_References_In_Identifier): Call Set_Global_Type on a global
identifier rewritten as an explicit dereference, either directly
or after having first been rewritten as a function call.
(Save_References_In_Operator): Set N2 unconditionally and reuse it.
* sem_ch3.adb (Build_Derived_Record_Type): Add missing comment.
* sem_res.adb (Resolve_Implicit_Dereference): Remove special bypass
for private views in instances.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch7.adb | 24 ++------
gcc/ada/sem_ch12.adb | 139 ++++++++++++++++++++++++-------------------
gcc/ada/sem_ch3.adb | 9 ++-
gcc/ada/sem_res.adb | 11 ----
4 files changed, 92 insertions(+), 91 deletions(-)
@@ -394,13 +394,9 @@ package body Exp_Ch7 is
-- Check recursively whether a loop or block contains a subprogram that
-- may need an activation record.
- function Convert_View
- (Proc : Entity_Id;
- Arg : Node_Id;
- Ind : Pos := 1) return Node_Id;
+ function Convert_View (Proc : Entity_Id; Arg : Node_Id) return Node_Id;
-- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
- -- argument being passed to it. Ind indicates which formal of procedure
- -- Proc we are trying to match. This function will, if necessary, generate
+ -- argument being passed to it. This function will, if necessary, generate
-- a conversion between the partial and full view of Arg to match the type
-- of the formal of Proc, or force a conversion to the class-wide type in
-- the case where the operation is abstract.
@@ -4402,22 +4398,12 @@ package body Exp_Ch7 is
-- Convert_View --
------------------
- function Convert_View
- (Proc : Entity_Id;
- Arg : Node_Id;
- Ind : Pos := 1) return Node_Id
- is
- Fent : Entity_Id := First_Entity (Proc);
- Ftyp : Entity_Id;
+ function Convert_View (Proc : Entity_Id; Arg : Node_Id) return Node_Id is
+ Ftyp : constant Entity_Id := Etype (First_Formal (Proc));
+
Atyp : Entity_Id;
begin
- for J in 2 .. Ind loop
- Next_Entity (Fent);
- end loop;
-
- Ftyp := Etype (Fent);
-
if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then
Atyp := Entity (Subtype_Mark (Arg));
else
@@ -6964,8 +6964,61 @@ package body Sem_Ch12 is
(Instance : Entity_Id;
Is_Formal_Box : Boolean)
is
- E : Entity_Id;
+ Gen_Id : constant Entity_Id
+ := (if Is_Generic_Unit (Instance) then
+ Instance
+ elsif Is_Wrapper_Package (Instance) then
+ Generic_Parent
+ (Specification
+ (Unit_Declaration_Node (Related_Instance (Instance))))
+ else
+ Generic_Parent (Package_Specification (Instance)));
+ -- The generic unit
+
+ Parent_Scope : constant Entity_Id := Scope (Gen_Id);
+ -- The enclosing scope of the generic unit
+
+ procedure Check_Actual_Type (Typ : Entity_Id);
+ -- If the type of the actual is a private type declared in the
+ -- enclosing scope of the generic unit, the body of the generic
+ -- sees the full view of the type (because it has to appear in
+ -- the corresponding package body). If the type is private now,
+ -- exchange views to restore the proper visibility in the instance.
+
+ -----------------------
+ -- Check_Actual_Type --
+ -----------------------
+
+ procedure Check_Actual_Type (Typ : Entity_Id) is
+ Btyp : constant Entity_Id := Base_Type (Typ);
+
+ begin
+ -- The exchange is only needed if the generic is defined
+ -- within a package which is not a common ancestor of the
+ -- scope of the instance, and is not already in scope.
+
+ if Is_Private_Type (Btyp)
+ and then Scope (Btyp) = Parent_Scope
+ and then Ekind (Parent_Scope) in E_Package | E_Generic_Package
+ and then Scope (Instance) /= Parent_Scope
+ and then not Is_Child_Unit (Gen_Id)
+ then
+ Switch_View (Btyp);
+
+ -- If the type of the entity is a subtype, it may also have
+ -- to be made visible, together with the base type of its
+ -- full view, after exchange.
+
+ if Is_Private_Type (Typ) then
+ Switch_View (Typ);
+ Switch_View (Base_Type (Typ));
+ end if;
+ end if;
+ end Check_Actual_Type;
+
Astype : Entity_Id;
+ E : Entity_Id;
+ Formal : Node_Id;
begin
E := First_Entity (Instance);
@@ -7083,60 +7136,22 @@ package body Sem_Ch12 is
Set_Is_Hidden (E, False);
end if;
- if Ekind (E) = E_Constant then
-
- -- If the type of the actual is a private type declared in the
- -- enclosing scope of the generic unit, the body of the generic
- -- sees the full view of the type (because it has to appear in
- -- the corresponding package body). If the type is private now,
- -- exchange views to restore the proper visiblity in the instance.
-
- declare
- Typ : constant Entity_Id := Base_Type (Etype (E));
- -- The type of the actual
-
- Gen_Id : Entity_Id;
- -- The generic unit
-
- Parent_Scope : Entity_Id;
- -- The enclosing scope of the generic unit
-
- begin
- if Is_Wrapper_Package (Instance) then
- Gen_Id :=
- Generic_Parent
- (Specification
- (Unit_Declaration_Node
- (Related_Instance (Instance))));
- else
- Gen_Id :=
- Generic_Parent (Package_Specification (Instance));
- end if;
-
- Parent_Scope := Scope (Gen_Id);
+ -- Check directly the type of the actual objects
- -- The exchange is only needed if the generic is defined
- -- within a package which is not a common ancestor of the
- -- scope of the instance, and is not already in scope.
+ if Ekind (E) in E_Constant | E_Variable then
+ Check_Actual_Type (Etype (E));
- if Is_Private_Type (Typ)
- and then Scope (Typ) = Parent_Scope
- and then Scope (Instance) /= Parent_Scope
- and then Ekind (Parent_Scope) = E_Package
- and then not Is_Child_Unit (Gen_Id)
- then
- Switch_View (Typ);
+ -- As well as the type of formal parameters of actual subprograms
- -- If the type of the entity is a subtype, it may also have
- -- to be made visible, together with the base type of its
- -- full view, after exchange.
-
- if Is_Private_Type (Etype (E)) then
- Switch_View (Etype (E));
- Switch_View (Base_Type (Etype (E)));
- end if;
- end if;
- end;
+ elsif Ekind (E) in E_Function | E_Procedure
+ and then Is_Generic_Actual_Subprogram (E)
+ and then Present (Alias (E))
+ then
+ Formal := First_Formal (Alias (E));
+ while Present (Formal) loop
+ Check_Actual_Type (Etype (Formal));
+ Next_Formal (Formal);
+ end loop;
end if;
Next_Entity (E);
@@ -16561,8 +16576,10 @@ package body Sem_Ch12 is
and then Is_Global (Entity (Prefix (N2)))
then
Set_Associated_Node (N, Prefix (N2));
+ Set_Global_Type (N, Prefix (N2));
elsif Nkind (Prefix (N2)) = N_Function_Call
+ and then Is_Entity_Name (Name (Prefix (N2)))
and then Present (Entity (Name (Prefix (N2))))
and then Is_Global (Entity (Name (Prefix (N2))))
then
@@ -16573,6 +16590,9 @@ package body Sem_Ch12 is
Name =>
New_Occurrence_Of
(Entity (Name (Prefix (N2))), Loc))));
+ Set_Associated_Node
+ (Name (Prefix (N)), Name (Prefix (N2)));
+ Set_Global_Type (Name (Prefix (N)), Name (Prefix (N2)));
else
Set_Associated_Node (N, Empty);
@@ -16598,15 +16618,16 @@ package body Sem_Ch12 is
procedure Save_References_In_Operator (N : Node_Id) is
begin
+ N2 := Get_Associated_Node (N);
+
-- The node did not undergo a transformation
- if Nkind (N) = Nkind (Get_Associated_Node (N)) then
+ if Nkind (N) = Nkind (N2) then
if Nkind (N) = N_Op_Concat then
- Set_Is_Component_Left_Opnd (N,
- Is_Component_Left_Opnd (Get_Associated_Node (N)));
-
- Set_Is_Component_Right_Opnd (N,
- Is_Component_Right_Opnd (Get_Associated_Node (N)));
+ Set_Is_Component_Left_Opnd
+ (N, Is_Component_Left_Opnd (N2));
+ Set_Is_Component_Right_Opnd
+ (N, Is_Component_Right_Opnd (N2));
end if;
Reset_Entity (N);
@@ -16616,8 +16637,6 @@ package body Sem_Ch12 is
-- applicable.
else
- N2 := Get_Associated_Node (N);
-
-- The operator resoved to a function call
if Nkind (N2) = N_Function_Call then
@@ -9037,9 +9037,16 @@ package body Sem_Ch3 is
-- Start of processing for Build_Derived_Record_Type
begin
+ -- If the parent type is a private extension with discriminants, we
+ -- need to have an unconstrained type on which to apply the inherited
+ -- constraint, so we get to the full view. However, this means that the
+ -- derived type and its implicit base type created below will not point
+ -- to the same view of their respective parent type and, thus, special
+ -- glue code like Exp_Ch7.Convert_View is needed to bridge this gap.
+
if Ekind (Parent_Type) = E_Record_Type_With_Private
- and then Present (Full_View (Parent_Type))
and then Has_Discriminants (Parent_Type)
+ and then Present (Full_View (Parent_Type))
then
Parent_Base := Base_Type (Full_View (Parent_Type));
else
@@ -9601,17 +9601,6 @@ package body Sem_Res is
Desig_Typ : Entity_Id;
begin
- -- In an instance the proper view may not always be correct for
- -- private types, see e.g. Sem_Type.Covers for similar handling.
-
- if Is_Private_Type (Etype (P))
- and then Present (Full_View (Etype (P)))
- and then Is_Access_Type (Full_View (Etype (P)))
- and then In_Instance
- then
- Set_Etype (P, Full_View (Etype (P)));
- end if;
-
if Is_Access_Type (Etype (P)) then
Desig_Typ := Implicitly_Designated_Type (Etype (P));
Insert_Explicit_Dereference (P);