public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-1985] ada: Further fixes to handling of private views in instances
@ 2023-06-20 11:26 Marc Poulhi?s
0 siblings, 0 replies; only message in thread
From: Marc Poulhi?s @ 2023-06-20 11:26 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:865c5db7cbc16de9887d5941be9a63a7fa03692e
commit r14-1985-g865c5db7cbc16de9887d5941be9a63a7fa03692e
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Thu Jun 1 13:25:53 2023 +0200
ada: Further fixes to handling of private views in instances
This removes more bypasses for private views in instances that are present
in type predicates (Conforming_Types, Covers, Specific_Type and Wrong_Type),
which in exchange requires additional work in Sem_Ch12 to restore the proper
view of types during the instantiation of generic bodies.
The main mechanism for this is the Has_Private_View flag, but it comes with
the limitations that 1) there must be a direct reference to the global type
in the generic construct (either a reference to a global object of this type
or the explicit declaration of a local object of this type), which is not
always the case e.g. for loop parameters and 2) it can deal with a single
type at a time, e.g. it cannot deal with an array type and its component
type if their respective views are not the same in the instance.
To overcome the second limitation, a new Has_Secondary_Private_View flag
is introduced to deal with a secondary type, which as of this writing is
either the component type of an array type or the designated type of an
access type (together they make up the vast majority of the problematic
cases for the Has_Private_View flag alone). This new mechanism subsumes
a specific treatment for them that was added in Copy_Generic_Node a few
years ago, although a specific treatment still needs to be preserved for
comparison and equality operators in a narrower case.
Additional handling is also introduced to overcome the first limitation
for loop parameters in Copy_Generic_Node, and a relaxed condition is used
in Exp_Ch7.Convert_View to generate an unchecked conversion between views.
gcc/ada/
* exp_ch7.adb (Convert_View): Detect more cases of mismatches for
private types and use Implementation_Base_Type as main criterion.
* gen_il-fields.ads (Opt_Field_Enum): Add
Has_Secondary_Private_View
* gen_il-gen-gen_nodes.adb (N_Expanded_Name): Likewise.
(N_Direct_Name): Likewise.
(N_Op): Likewise.
* sem_ch12.ads (Check_Private_View): Document the usage of second
flag Has_Secondary_Private_View.
* sem_ch12.adb (Get_Associated_Entity): New function to retrieve
the ultimate associated entity, if any.
(Check_Private_View): Implement Has_Secondary_Private_View
support.
(Copy_Generic_Node): Remove specific treatment for Component_Type
of an array type and Designated_Type of an access type. Add
specific treatment for comparison and equality operators, as well
as iterator and loop parameter specifications.
(Instantiate_Type): Implement Has_Secondary_Private_View support.
(Requires_Delayed_Save): Call Get_Associated_Entity.
(Set_Global_Type): Implement Has_Secondary_Private_View support.
* sem_ch6.adb (Conforming_Types): Remove bypass for private views
in instances.
* sem_type.adb (Covers): Return true if Is_Subtype_Of does so.
Remove bypass for private views in instances.
(Specific_Type): Likewise.
* sem_util.adb (Wrong_Type): Likewise.
* sinfo.ads (Has_Secondary_Private_View): Document new flag.
Diff:
---
gcc/ada/exp_ch7.adb | 12 +-
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_nodes.adb | 7 +-
gcc/ada/sem_ch12.adb | 295 ++++++++++++++++++++-------------------
gcc/ada/sem_ch12.ads | 4 +-
gcc/ada/sem_ch6.adb | 17 +--
gcc/ada/sem_type.adb | 31 ++--
gcc/ada/sem_util.adb | 50 -------
gcc/ada/sinfo.ads | 39 ++++--
9 files changed, 219 insertions(+), 237 deletions(-)
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index f82301c0acd..1b16839ddf3 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -4413,11 +4413,13 @@ package body Exp_Ch7 is
if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
- elsif Ftyp /= Atyp
- and then Present (Atyp)
- and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
- and then Base_Type (Underlying_Type (Atyp)) =
- Base_Type (Underlying_Type (Ftyp))
+ elsif Present (Atyp)
+ and then Atyp /= Ftyp
+ and then (Is_Private_Type (Ftyp)
+ or else Is_Private_Type (Atyp)
+ or else Is_Private_Type (Base_Type (Atyp)))
+ and then Implementation_Base_Type (Atyp) =
+ Implementation_Base_Type (Ftyp)
then
return Unchecked_Convert_To (Ftyp, Arg);
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index c62523d9075..a017f45d9a6 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -210,6 +210,7 @@ package Gen_IL.Fields is
Has_Pragma_Suppress_All,
Has_Private_View,
Has_Relative_Deadline_Pragma,
+ Has_Secondary_Private_View,
Has_Self_Reference,
Has_SP_Choice,
Has_Storage_Size_Pragma,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 19551fd8659..2ad6e60dae8 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -170,13 +170,15 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Selector_Name, Node_Id, Default_Empty),
Sm (Atomic_Sync_Required, Flag),
Sm (Has_Private_View, Flag),
+ Sm (Has_Secondary_Private_View, Flag),
Sm (Is_Elaboration_Checks_OK_Node, Flag),
Sm (Is_Elaboration_Warnings_OK_Node, Flag),
Sm (Is_SPARK_Mode_On_Node, Flag),
Sm (Redundant_Use, Flag)));
Ab (N_Direct_Name, N_Has_Entity,
- (Sm (Has_Private_View, Flag)));
+ (Sm (Has_Private_View, Flag),
+ Sm (Has_Secondary_Private_View, Flag)));
Cc (N_Identifier, N_Direct_Name,
(Sy (Chars, Name_Id, Default_No_Name),
@@ -197,7 +199,8 @@ begin -- Gen_IL.Gen.Gen_Nodes
Ab (N_Op, N_Has_Entity,
(Sm (Do_Overflow_Check, Flag),
- Sm (Has_Private_View, Flag)));
+ Sm (Has_Private_View, Flag),
+ Sm (Has_Secondary_Private_View, Flag)));
Ab (N_Binary_Op, N_Op);
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index a8e7c909c39..d5280cea712 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -660,6 +660,9 @@ package body Sem_Ch12 is
-- the instance and the generic, so that the back-end can establish the
-- proper order of elaboration.
+ function Get_Associated_Entity (Id : Entity_Id) return Entity_Id;
+ -- Similar to Get_Associated_Node below, but for entities
+
function Get_Associated_Node (N : Node_Id) return Node_Id;
-- In order to propagate semantic information back from the analyzed copy
-- to the original generic, we maintain links between selected nodes in the
@@ -6119,6 +6122,25 @@ package body Sem_Ch12 is
Restore_SPARK_Mode (Saved_SM, Saved_SMP);
end Analyze_Subprogram_Instantiation;
+ ---------------------------
+ -- Get_Associated_Entity --
+ ---------------------------
+
+ function Get_Associated_Entity (Id : Entity_Id) return Entity_Id is
+ Assoc : Entity_Id;
+
+ begin
+ Assoc := Associated_Entity (Id);
+
+ if Present (Assoc) then
+ while Present (Associated_Entity (Assoc)) loop
+ Assoc := Associated_Entity (Assoc);
+ end loop;
+ end if;
+
+ return Assoc;
+ end Get_Associated_Entity;
+
-------------------------
-- Get_Associated_Node --
-------------------------
@@ -7619,46 +7641,36 @@ package body Sem_Ch12 is
------------------------
procedure Check_Private_View (N : Node_Id) is
- T : constant Entity_Id := Etype (N);
- BT : Entity_Id;
+ Typ : constant Entity_Id := Etype (N);
- begin
- -- Exchange views if the type was not private in the generic but is
- -- private at the point of instantiation. Do not exchange views if
- -- the scope of the type is in scope. This can happen if both generic
- -- and instance are sibling units, or if type is defined in a parent.
- -- In this case the visibility of the type will be correct for all
- -- semantic checks.
+ procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean);
+ -- Check that the available view of T matches Private_View and, if not,
+ -- switch the view of T or of its base type.
+
+ procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean) is
+ BT : constant Entity_Id := Base_Type (T);
+
+ begin
+ -- If the full declaration was not visible in the generic, stop here
+
+ if Private_View then
+ return;
+ end if;
- if Present (T) then
- BT := Base_Type (T);
+ -- Exchange views if the type was not private in the generic but is
+ -- private at the point of instantiation. Do not exchange views if
+ -- the scope of the type is in scope. This can happen if both generic
+ -- and instance are sibling units, or if type is defined in a parent.
+ -- In this case the visibility of the type will be correct for all
+ -- semantic checks.
if Is_Private_Type (T)
- and then not Has_Private_View (N)
and then Present (Full_View (T))
and then not In_Open_Scopes (Scope (T))
then
- -- In the generic, the full declaration was visible
-
Switch_View (T);
- elsif Has_Private_View (N)
- and then not Is_Private_Type (T)
- and then not Has_Been_Exchanged (T)
- and then (not In_Open_Scopes (Scope (T))
- or else Nkind (Parent (N)) = N_Subtype_Declaration)
- then
- -- In the generic, only the private declaration was visible
-
- -- If the type appears in a subtype declaration, the subtype in
- -- instance must have a view compatible with that of its parent,
- -- which must be exchanged (see corresponding code in Restore_
- -- Private_Views) so we make an exception to the open scope rule.
-
- Prepend_Elmt (T, Exchanged_Views);
- Exchange_Declarations (Etype (Get_Associated_Node (N)));
-
- -- Finally, a non-private subtype may have a private base type, which
+ -- Finally, a nonprivate subtype may have a private base type, which
-- must be exchanged for consistency. This can happen when a package
-- body is instantiated, when the scope stack is empty but in fact
-- the subtype and the base type are declared in an enclosing scope.
@@ -7670,15 +7682,46 @@ package body Sem_Ch12 is
-- provision for that case in Switch_View).
elsif not Is_Private_Type (T)
- and then not Has_Private_View (N)
and then Is_Private_Type (BT)
and then Present (Full_View (BT))
- and then not Is_Generic_Type (BT)
and then not In_Open_Scopes (BT)
then
Prepend_Elmt (Full_View (BT), Exchanged_Views);
Exchange_Declarations (BT);
end if;
+ end Check_Private_Type;
+
+ begin
+ if Present (Typ) then
+ -- If the type appears in a subtype declaration, the subtype in
+ -- instance must have a view compatible with that of its parent,
+ -- which must be exchanged (see corresponding code in Restore_
+ -- Private_Views) so we make an exception to the open scope rule
+ -- implemented by Check_Private_Type above.
+
+ if Has_Private_View (N)
+ and then not Is_Private_Type (Typ)
+ and then not Has_Been_Exchanged (Typ)
+ and then (not In_Open_Scopes (Scope (Typ))
+ or else Nkind (Parent (N)) = N_Subtype_Declaration)
+ then
+ -- In the generic, only the private declaration was visible
+
+ Prepend_Elmt (Typ, Exchanged_Views);
+ Exchange_Declarations (Etype (Get_Associated_Node (N)));
+
+ else
+ Check_Private_Type (Typ, Has_Private_View (N));
+
+ if Is_Access_Type (Typ) then
+ Check_Private_Type
+ (Designated_Type (Typ), Has_Secondary_Private_View (N));
+
+ elsif Is_Array_Type (Typ) then
+ Check_Private_Type
+ (Component_Type (Typ), Has_Secondary_Private_View (N));
+ end if;
+ end if;
end if;
end Check_Private_View;
@@ -8054,115 +8097,34 @@ package body Sem_Ch12 is
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
- -- Here we deal with a very peculiar case for which the
- -- Has_Private_View mechanism is not sufficient, because
- -- the reference to the type is implicit in the tree,
- -- that is to say, it's not referenced from a node but
- -- only from another type, namely through Component_Type.
-
- -- package P is
-
- -- type Pt is private;
-
- -- generic
- -- type Ft is array (Positive range <>) of Pt;
- -- package G is
- -- procedure Check (F1, F2 : Ft; Lt : Boolean);
- -- end G;
-
- -- private
- -- type Pt is new Boolean;
- -- end P;
-
- -- package body P is
- -- package body G is
- -- procedure Check (F1, F2 : Ft; Lt : Boolean) is
- -- begin
- -- if (F1 < F2) /= Lt then
- -- null;
- -- end if;
- -- end Check;
- -- end G;
- -- end P;
-
- -- type Arr is array (Positive range <>) of P.Pt;
-
- -- package Inst is new P.G (Arr);
-
- -- Pt is a global type for the generic package G and it
- -- is not referenced in its body, but only as component
- -- type of Ft, which is a local type. This means that no
- -- references to Pt or Ft are seen during the copy of the
- -- body, the only reference to Pt being seen is when the
- -- actuals are checked by Check_Generic_Actuals, but Pt
- -- is still private at this point. In the end, the views
- -- of Pt are not switched in the body and, therefore, the
- -- array comparison is rejected because the component is
- -- still private.
-
- -- Adding e.g. a dummy variable of type Pt in the body is
- -- sufficient to make everything work, so we generate an
- -- artificial reference to Pt on the fly and thus force
- -- the switching of views on the grounds that, if the
- -- comparison was accepted during the semantic analysis
- -- of the generic, this means that the component cannot
- -- have been private (see Sem_Type.Valid_Comparison_Arg).
-
- if Nkind (Assoc) in N_Op_Compare
- and then Present (Etype (Left_Opnd (Assoc)))
- and then Is_Array_Type (Etype (Left_Opnd (Assoc)))
- and then Present (Etype (Right_Opnd (Assoc)))
- and then Is_Array_Type (Etype (Right_Opnd (Assoc)))
+ -- For the comparison and equality operators, the Etype
+ -- of the operator does not provide any information so,
+ -- if one of the operands is of a universal type, we need
+ -- to manually restore the full view of private types.
+
+ if Nkind (N) in N_Op_Eq
+ | N_Op_Ge
+ | N_Op_Gt
+ | N_Op_Le
+ | N_Op_Lt
+ | N_Op_Ne
then
- declare
- Ltyp : constant Entity_Id :=
- Etype (Left_Opnd (Assoc));
- Rtyp : constant Entity_Id :=
- Etype (Right_Opnd (Assoc));
- begin
- if Is_Private_Type (Component_Type (Ltyp)) then
- Check_Private_View
- (New_Occurrence_Of (Component_Type (Ltyp),
- Sloc (N)));
- end if;
- if Is_Private_Type (Component_Type (Rtyp)) then
- Check_Private_View
- (New_Occurrence_Of (Component_Type (Rtyp),
- Sloc (N)));
+ if Yields_Universal_Type (Left_Opnd (Assoc)) then
+ if Present (Etype (Right_Opnd (Assoc)))
+ and then
+ Is_Private_Type (Etype (Right_Opnd (Assoc)))
+ then
+ Switch_View (Etype (Right_Opnd (Assoc)));
end if;
- end;
-
- -- Here is a similar case, for the Designated_Type of an
- -- access type that is present as target type in a type
- -- conversion from another access type. In this case, if
- -- the base types of the designated types are different
- -- and the conversion was accepted during the semantic
- -- analysis of the generic, this means that the target
- -- type cannot have been private (see Valid_Conversion).
-
- elsif Nkind (Assoc) = N_Identifier
- and then Nkind (Parent (Assoc)) = N_Type_Conversion
- and then Subtype_Mark (Parent (Assoc)) = Assoc
- and then Present (Etype (Assoc))
- and then Is_Access_Type (Etype (Assoc))
- and then Present (Etype (Expression (Parent (Assoc))))
- and then
- Is_Access_Type (Etype (Expression (Parent (Assoc))))
- then
- declare
- Targ_Desig : constant Entity_Id :=
- Designated_Type (Etype (Assoc));
- Expr_Desig : constant Entity_Id :=
- Designated_Type
- (Etype (Expression (Parent (Assoc))));
- begin
- if Base_Type (Targ_Desig) /= Base_Type (Expr_Desig)
- and then Is_Private_Type (Targ_Desig)
+
+ elsif Yields_Universal_Type (Right_Opnd (Assoc)) then
+ if Present (Etype (Left_Opnd (Assoc)))
+ and then
+ Is_Private_Type (Etype (Left_Opnd (Assoc)))
then
- Check_Private_View
- (New_Occurrence_Of (Targ_Desig, Sloc (N)));
+ Switch_View (Etype (Left_Opnd (Assoc)));
end if;
- end;
+ end if;
end if;
-- The node is a reference to a global type and acts as the
@@ -8423,7 +8385,7 @@ package body Sem_Ch12 is
-- install the full view (and that of its ancestors, if any).
declare
- T : Entity_Id := (Etype (Get_Associated_Node (New_N)));
+ T : Entity_Id := Etype (Get_Associated_Node (N));
Rt : Entity_Id;
begin
@@ -8509,6 +8471,32 @@ package body Sem_Ch12 is
Copy_Descendants;
end;
+ -- Iterator and loop parameter specifications do not have an identifier
+ -- denoting the index type, so we must locate it through the expression
+ -- to check whether the views are consistent.
+
+ elsif Nkind (N) in N_Iterator_Specification
+ | N_Loop_Parameter_Specification
+ and then Instantiating
+ then
+ declare
+ Id : constant Entity_Id :=
+ Get_Associated_Entity (Defining_Identifier (N));
+
+ Index_T : Entity_Id;
+
+ begin
+ if Present (Id) and then Present (Etype (Id)) then
+ Index_T := First_Subtype (Etype (Id));
+
+ if Present (Index_T) and then Is_Private_Type (Index_T) then
+ Switch_View (Index_T);
+ end if;
+ end if;
+
+ Copy_Descendants;
+ end;
+
-- For a proper body, we must catch the case of a proper body that
-- replaces a stub. This represents the point at which a separate
-- compilation unit, and hence template file, may be referenced, so we
@@ -14328,6 +14316,13 @@ package body Sem_Ch12 is
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)))
+ or else (Is_Array_Type (Act_T)
+ and then Is_Private_Type (Component_Type (Act_T)))
+ then
+ Set_Has_Secondary_Private_View (Subtype_Indication (Decl_Node));
end if;
-- In Ada 2012 the actual may be a limited view. Indicate that
@@ -16379,7 +16374,7 @@ package body Sem_Ch12 is
return
Is_Generic_Declaration_Or_Body
(Unit_Declaration_Node
- (Associated_Entity (Defining_Entity (Nod))));
+ (Get_Associated_Entity (Defining_Entity (Nod))));
-- Otherwise the generic unit being processed is not the top
-- level template. It is safe to capture of global references
@@ -16835,14 +16830,26 @@ package body Sem_Ch12 is
-- type is already the full view (see below). Indicate that the
-- original node has a private view.
- if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then
- Set_Has_Private_View (N);
+ if Entity (N) /= N2 then
+ if Has_Private_View (Entity (N)) then
+ Set_Has_Private_View (N);
+ end if;
+
+ if Has_Secondary_Private_View (Entity (N)) then
+ Set_Has_Secondary_Private_View (N);
+ end if;
end if;
- -- If not a private type, nothing else to do
+ -- If not a private type, deal with a secondary private view
if not Is_Private_Type (Typ) then
- null;
+ if (Is_Access_Type (Typ)
+ and then Is_Private_Type (Designated_Type (Typ)))
+ or else (Is_Array_Type (Typ)
+ and then Is_Private_Type (Component_Type (Typ)))
+ then
+ Set_Has_Secondary_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.
diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
index 52e100ef2b7..3bf8fe97636 100644
--- a/gcc/ada/sem_ch12.ads
+++ b/gcc/ada/sem_ch12.ads
@@ -204,7 +204,9 @@ package Sem_Ch12 is
-- the current view after instantiation. The processing is driven by the
-- current private status of the type of the node, and Has_Private_View,
-- a flag that is set at the point of generic compilation. If view and
- -- flag are inconsistent then the type is updated appropriately.
+ -- flag are inconsistent then the type is updated appropriately. A second
+ -- flag Has_Secondary_Private_View is used to update a second type related
+ -- to this type if need be.
--
-- This subprogram is used in Check_Generic_Actuals and Copy_Generic_Node,
-- and is exported here for the purpose of front-end inlining (see Exp_Ch6.
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 17c50f6e676..62ca985bf87 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -8410,21 +8410,14 @@ package body Sem_Ch6 is
Ctype <= Mode_Conformant
or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
- elsif Is_Private_Type (Type_2)
- and then In_Instance
- and then Present (Full_View (Type_2))
- and then Base_Types_Match (Type_1, Full_View (Type_2))
- then
- return
- Ctype <= Mode_Conformant
- or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
-
- -- Another confusion between views in a nested instance with an
- -- actual private type whose full view is not in scope.
+ -- The subtype declared for the formal type in an instantiation and the
+ -- actual type are conforming. Note that testing Is_Generic_Actual_Type
+ -- here is not sufficient because the flag is only set in the bodies of
+ -- instances, which is too late for formal subprograms.
elsif Ekind (Type_2) = E_Private_Subtype
- and then In_Instance
and then Etype (Type_2) = Type_1
+ and then Present (Generic_Parent_Type (Declaration_Node (Type_2)))
then
return True;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 8519b97fa41..00a64152df1 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -884,6 +884,16 @@ package body Sem_Type is
end;
end if;
+ -- This test may seem to be redundant with the above one, but it catches
+ -- peculiar cases where a private type declared in a package is used in
+ -- a generic construct declared in another package, and the body of the
+ -- former package contains an instantiation of the generic construct on
+ -- an object whose type is a subtype of the private type; in this case,
+ -- the subtype is not private but the type is private in the instance.
+
+ elsif Is_Subtype_Of (T1 => T2, T2 => T1) then
+ return True;
+
-- Literals are compatible with types in a given "class"
elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
@@ -1161,20 +1171,20 @@ package body Sem_Type is
then
return True;
- -- In instances, or with types exported from instantiations, check
- -- whether a partial and a full view match. Verify that types are
- -- legal, to prevent cascaded errors.
+ -- With types exported from instantiations, check whether a partial and
+ -- a full view match. Verify that types are legal, to prevent cascaded
+ -- errors.
elsif Is_Private_Type (T1)
- and then (In_Instance
- or else (Is_Type (T2) and then Is_Generic_Actual_Type (T2)))
+ and then Is_Type (T2)
+ and then Is_Generic_Actual_Type (T2)
and then Full_View_Covers (T1, T2)
then
return True;
elsif Is_Private_Type (T2)
- and then (In_Instance
- or else (Is_Type (T1) and then Is_Generic_Actual_Type (T1)))
+ and then Is_Type (T1)
+ and then Is_Generic_Actual_Type (T1)
and then Full_View_Covers (T2, T1)
then
return True;
@@ -3457,9 +3467,10 @@ package body Sem_Type is
then
return T2;
- -- In instances, also check private views the same way as Covers
+ -- With types exported from instantiation, also check private views the
+ -- same way as Covers
- elsif Is_Private_Type (T1) and then In_Instance then
+ elsif Is_Private_Type (T1) and then Is_Generic_Actual_Type (T2) then
if Present (Full_View (T1)) then
return Specific_Type (Full_View (T1), T2);
@@ -3467,7 +3478,7 @@ package body Sem_Type is
return Specific_Type (Underlying_Full_View (T1), T2);
end if;
- elsif Is_Private_Type (T2) and then In_Instance then
+ elsif Is_Private_Type (T2) and then Is_Generic_Actual_Type (T1) then
if Present (Full_View (T2)) then
return Specific_Type (T1, Full_View (T2));
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 1729a2addd8..d9ea00e53cb 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -29510,56 +29510,6 @@ package body Sem_Util is
and then Full_View (Etype (Expr)) = Expec_Type
then
return;
-
- -- In an instance, there is an ongoing problem with completion of
- -- types derived from private types. Their structure is what Gigi
- -- expects, but the Etype is the parent type rather than the derived
- -- private type itself. Do not flag error in this case. The private
- -- completion is an entity without a parent, like an Itype. Similarly,
- -- full and partial views may be incorrect in the instance.
- -- There is no simple way to insure that it is consistent ???
-
- -- A similar view discrepancy can happen in an inlined body, for the
- -- same reason: inserted body may be outside of the original package
- -- and only partial views are visible at the point of insertion.
-
- -- If In_Generic_Actual (Expr) is True then we cannot assume that
- -- the successful semantic analysis of the generic guarantees anything
- -- useful about type checking of this instance, so we ignore
- -- In_Instance in that case. There may be cases where this is not
- -- right (the symptom would probably be rejecting something
- -- that ought to be accepted) but we don't currently have any
- -- concrete examples of this.
-
- elsif (In_Instance and then not In_Generic_Actual (Expr))
- or else In_Inlined_Body
- then
- if Etype (Etype (Expr)) = Etype (Expected_Type)
- and then
- (Has_Private_Declaration (Expected_Type)
- or else Has_Private_Declaration (Etype (Expr)))
- and then No (Parent (Expected_Type))
- then
- return;
-
- elsif Nkind (Parent (Expr)) = N_Qualified_Expression
- and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type
- then
- return;
-
- elsif Is_Private_Type (Expected_Type)
- and then Present (Full_View (Expected_Type))
- and then Covers (Full_View (Expected_Type), Etype (Expr))
- then
- return;
-
- -- Conversely, type of expression may be the private one
-
- elsif Is_Private_Type (Base_Type (Etype (Expr)))
- and then Full_View (Base_Type (Etype (Expr))) = Expected_Type
- then
- return;
- end if;
end if;
-- Avoid printing internally generated subtypes in error messages and
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 8040a59e175..57fd704475c 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -389,21 +389,23 @@ package Sinfo is
-- abbreviations are used:
-- "plus fields for binary operator"
- -- Chars Name_Id for the operator
- -- Left_Opnd left operand expression
- -- Right_Opnd right operand expression
- -- Entity defining entity for operator
- -- Associated_Node for generic processing
- -- Do_Overflow_Check set if overflow check needed
- -- Has_Private_View set in generic units.
+ -- Chars Name_Id for the operator
+ -- Left_Opnd left operand expression
+ -- Right_Opnd right operand expression
+ -- Entity defining entity for operator
+ -- Associated_Node for generic processing
+ -- Do_Overflow_Check set if overflow check needed
+ -- Has_Private_View set in generic units
+ -- Has_Secondary_Private_View set in generic units
-- "plus fields for unary operator"
- -- Chars Name_Id for the operator
- -- Right_Opnd right operand expression
- -- Entity defining entity for operator
- -- Associated_Node for generic processing
- -- Do_Overflow_Check set if overflow check needed
- -- Has_Private_View set in generic units.
+ -- Chars Name_Id for the operator
+ -- Right_Opnd right operand expression
+ -- Entity defining entity for operator
+ -- Associated_Node for generic processing
+ -- Do_Overflow_Check set if overflow check needed
+ -- Has_Private_View set in generic units
+ -- Has_Secondary_Private_View set in generic units
-- "plus fields for expression"
-- Paren_Count number of parentheses levels
@@ -1457,6 +1459,13 @@ package Sinfo is
-- A flag present in N_Subprogram_Body and N_Task_Definition nodes to
-- flag the presence of a pragma Relative_Deadline.
+ -- Has_Secondary_Private_View
+ -- A flag present in generic nodes that have an entity, to indicate that
+ -- the node is either of an access type whose Designated_Type is private
+ -- or of an array type whose Component_Type is private. Used to exchange
+ -- private and full declarations if the visibility at instantiation is
+ -- different from the visibility at generic definition.
+
-- Has_Self_Reference
-- Present in N_Aggregate and N_Extension_Aggregate. Indicates that one
-- of the expressions contains an access attribute reference to the
@@ -2522,6 +2531,7 @@ package Sinfo is
-- Is_SPARK_Mode_On_Node
-- Is_Elaboration_Warnings_OK_Node
-- Has_Private_View (set in generic units)
+ -- Has_Secondary_Private_View (set in generic units)
-- Redundant_Use
-- Atomic_Sync_Required
-- plus fields for expression
@@ -2605,6 +2615,7 @@ package Sinfo is
-- Entity
-- Associated_Node
-- Has_Private_View (set in generic units)
+ -- Has_Secondary_Private_View (set in generic units)
-- plus fields for expression
-- Note: the Entity field will be missing (set to Empty) for character
@@ -5388,6 +5399,7 @@ package Sinfo is
-- Associated_Node Note this is shared with Entity
-- Etype
-- Has_Private_View (set in generic units)
+ -- Has_Secondary_Private_View (set in generic units)
-- Note: the Strval field may be set to No_String for generated
-- operator symbols that are known not to be string literals
@@ -8030,6 +8042,7 @@ package Sinfo is
-- Is_SPARK_Mode_On_Node
-- Is_Elaboration_Warnings_OK_Node
-- Has_Private_View (set in generic units)
+ -- Has_Secondary_Private_View (set in generic units)
-- Redundant_Use
-- Atomic_Sync_Required
-- plus fields for expression
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-06-20 11:26 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-06-20 11:26 [gcc r14-1985] ada: Further fixes to handling of private views in instances Marc Poulhi?s
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).