* [COMMITTED] ada: Fix spurious visibility error on parent's component in instance
@ 2023-12-19 14:30 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-12-19 14:30 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
This occurs for an aggregate of a derived tagged type in the body of the
instance, because the full view of the parent type, which was visible in
the generic construct (otherwise the aggregate would have been illegal),
is not restored in the body of the instance.
Copy_Generic_Node already contains code to restore the full view in this
case, but it works only if the derived tagged type is itself global to
the generic construct, and not if the derived tagged type is local but
the parent type global, as is the case here.
gcc/ada/
* gen_il-fields.ads (Aggregate_Bounds): Rename to
Aggregate_Bounds_Or_Ancestor_Type.
* gen_il-gen-gen_nodes.adb (Aggregate_Bounds): Likewise.
* sem_aggr.adb (Resolve_Record_Aggregate): Remove obsolete bypass.
* sem_ch12.adb (Check_Generic_Actuals): Add decoration.
(Copy_Generic_Node): For an extension aggregate, restore only the
full view, if any. For a full aggregate, restore the full view as
well as that of its Ancestor_Type, if any, and up to the root type.
(Save_References_In_Aggregate): For a full aggregate of a local
derived tagged type with a global ancestor, set Ancestor_Type to
this ancestor. For a full aggregate of a global derived tagged
type, set Ancestor_Type to the parent type.
* sinfo-utils.ads (Aggregate_Bounds): New function renaming.
(Ancestor_Type): Likewise.
(Set_Aggregate_Bounds): New procedure renaming.
(Set_Ancestor_Type): Likewise.
* sinfo.ads (Ancestor_Type): Document new field.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gen_il-fields.ads | 2 +-
gcc/ada/gen_il-gen-gen_nodes.adb | 2 +-
gcc/ada/sem_aggr.adb | 8 +--
gcc/ada/sem_ch12.adb | 107 +++++++++++++++++++++++--------
gcc/ada/sinfo-utils.ads | 16 +++++
gcc/ada/sinfo.ads | 7 +-
6 files changed, 107 insertions(+), 35 deletions(-)
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index c565e19701d..632ce489b08 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -66,7 +66,7 @@ package Gen_IL.Fields is
Acts_As_Spec,
Actual_Designated_Subtype,
Address_Warning_Posted,
- Aggregate_Bounds,
+ Aggregate_Bounds_Or_Ancestor_Type,
Aliased_Present,
All_Others,
All_Present,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 087f78567f4..064d25fbd79 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -493,7 +493,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Is_Parenthesis_Aggregate, Flag),
Sy (Is_Homogeneous_Aggregate, Flag),
Sy (Is_Enum_Array_Aggregate, Flag),
- Sm (Aggregate_Bounds, Node_Id),
+ Sm (Aggregate_Bounds_Or_Ancestor_Type, Node_Id),
Sm (Entity_Or_Associated_Node, Node_Id), -- just Associated_Node
Sm (Compile_Time_Known_Aggregate, Flag),
Sm (Expansion_Delayed, Flag),
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index e1e7b8bac37..a61326c9ae2 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -5644,18 +5644,14 @@ package body Sem_Aggr is
Parent_Typ := Etype (Parent_Typ);
-- Check whether a private parent requires the use of
- -- an extension aggregate. This test does not apply in
- -- an instantiation: if the generic unit is legal so is
- -- the instance.
+ -- an extension aggregate.
if Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Type_Declaration
or else Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Extension_Declaration
then
- if Nkind (N) /= N_Extension_Aggregate
- and then not In_Instance
- then
+ if Nkind (N) /= N_Extension_Aggregate then
Error_Msg_NE
("type of aggregate has private ancestor&!",
N, Parent_Typ);
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index e229d217555..2b8436d7c18 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -7059,10 +7059,14 @@ package body Sem_Ch12 is
end if;
end Check_Actual_Type;
+ -- Local variables
+
Astype : Entity_Id;
E : Entity_Id;
Formal : Node_Id;
+ -- Start of processing for Check_Generic_Actuals
+
begin
E := First_Entity (Instance);
while Present (E) loop
@@ -8495,38 +8499,46 @@ package body Sem_Ch12 is
Set_Associated_Node (N, New_N);
else
- if Present (Get_Associated_Node (N))
- and then Nkind (Get_Associated_Node (N)) = Nkind (N)
- then
- -- In the generic the aggregate has some composite type. If at
- -- the point of instantiation the type has a private view,
- -- install the full view (and that of its ancestors, if any).
+ -- If, in the generic, the aggregate has a global composite type
+ -- and, at the point of instantiation, the type has a private view
+ -- then install the full view.
- declare
- T : Entity_Id := Etype (Get_Associated_Node (N));
- Rt : Entity_Id;
+ declare
+ Assoc : constant Node_Id := Get_Associated_Node (N);
- begin
- if Present (T) and then Is_Private_Type (T) then
- Switch_View (T);
- end if;
+ begin
+ if Present (Assoc)
+ and then Nkind (Assoc) = Nkind (N)
+ and then Present (Etype (Assoc))
+ and then Is_Private_Type (Etype (Assoc))
+ then
+ Switch_View (Etype (Assoc));
+ end if;
+ end;
- if Present (T)
- and then Is_Tagged_Type (T)
- and then Is_Derived_Type (T)
- then
- Rt := Root_Type (T);
+ -- Moreover, for a full aggregate, if the type is a derived tagged
+ -- type and has a global ancestor, then also restore the full view
+ -- of this ancestor, and do so up to the root type.
- loop
- T := Etype (T);
+ if Nkind (N) = N_Aggregate
+ and then Present (Ancestor_Type (N))
+ then
+ declare
+ Root_Typ : constant Entity_Id :=
+ Root_Type (Ancestor_Type (N));
- if Is_Private_Type (T) then
- Switch_View (T);
- end if;
+ Typ : Entity_Id := Ancestor_Type (N);
- exit when T = Rt;
- end loop;
- end if;
+ begin
+ loop
+ if Is_Private_Type (Typ) then
+ Switch_View (Typ);
+ end if;
+
+ exit when Typ = Root_Typ;
+
+ Typ := Etype (Typ);
+ end loop;
end;
end if;
end if;
@@ -16505,6 +16517,36 @@ package body Sem_Ch12 is
if No (N2) or else No (Typ) or else not Is_Global (Typ) then
Set_Associated_Node (N, Empty);
+ -- For a full aggregate, if the type is local but is a derived
+ -- tagged type of a global ancestor, we will need to have the
+ -- full view of this global ancestor available in the instance
+ -- in order to analyze the full aggregate.
+
+ if Present (N2)
+ and then Nkind (N2) = N_Aggregate
+ and then Present (Typ)
+ and then Is_Tagged_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ then
+ declare
+ Root_Typ : constant Entity_Id := Root_Type (Typ);
+
+ Parent_Typ : Entity_Id := Typ;
+
+ begin
+ loop
+ Parent_Typ := Etype (Parent_Typ);
+
+ if Is_Global (Parent_Typ) then
+ Set_Ancestor_Type (N, Parent_Typ);
+ exit;
+ end if;
+
+ exit when Parent_Typ = Root_Typ;
+ end loop;
+ end;
+ end if;
+
-- If the aggregate is an actual in a call, it has been
-- resolved in the current context, to some local type. The
-- enclosing call may have been disambiguated by the aggregate,
@@ -16543,6 +16585,19 @@ package body Sem_Ch12 is
Subtype_Mark => Nam,
Expression => Relocate_Node (N));
end if;
+
+ -- For a full aggregate, if the type is global and a derived
+ -- tagged type, we will also need to have the full view of its
+ -- ancestor available in the instance in order to analyze the
+ -- full aggregate.
+
+ elsif Present (N2)
+ and then Nkind (N2) = N_Aggregate
+ and then Present (Typ)
+ and then Is_Tagged_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ then
+ Set_Ancestor_Type (N, Etype (Typ));
end if;
if Nkind (N) = N_Aggregate then
diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads
index 6ce624888b1..75d8d257c11 100644
--- a/gcc/ada/sinfo-utils.ads
+++ b/gcc/ada/sinfo-utils.ads
@@ -157,6 +157,22 @@ package Sinfo.Utils is
(N : N_Inclusive_Has_Entity; Val : Node_Id)
renames Set_Entity_Or_Associated_Node;
+ ---------------------------------------------------
+ -- Aliases for Aggregate_Bounds_Or_Ancestor_Type --
+ ---------------------------------------------------
+
+ function Aggregate_Bounds (N : Node_Id) return Node_Id
+ renames Aggregate_Bounds_Or_Ancestor_Type;
+
+ function Ancestor_Type (N : Node_Id) return Node_Id
+ renames Aggregate_Bounds_Or_Ancestor_Type;
+
+ procedure Set_Aggregate_Bounds (N : Node_Id; Val : Node_Id)
+ renames Set_Aggregate_Bounds_Or_Ancestor_Type;
+
+ procedure Set_Ancestor_Type (N : Node_Id; Val : Node_Id)
+ renames Set_Aggregate_Bounds_Or_Ancestor_Type;
+
---------------
-- Debugging --
---------------
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 1a6317054cf..fc4589d2087 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -845,6 +845,11 @@ package Sinfo is
-- is used for translation of the at end handler into a normal exception
-- handler.
+ -- Ancestor_Type
+ -- Present in record N_Aggregate nodes. Used to store the first global
+ -- ancestor of the type of the aggregate in a generic context, if any,
+ -- when the type is a derived tagged type. Otherwise Empty.
+
-- Aspect_On_Partial_View
-- Present on an N_Aspect_Specification node. For an aspect that applies
-- to a type entity, indicates whether the specification appears on the
@@ -4081,7 +4086,7 @@ package Sinfo is
-- Expressions (set to No_List if none or null record case)
-- Component_Associations (set to No_List if none)
-- Null_Record_Present
- -- Aggregate_Bounds
+ -- Aggregate_Bounds (array) or Ancestor_Type (record)
-- Associated_Node
-- Compile_Time_Known_Aggregate
-- Expansion_Delayed
--
2.43.0
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-12-19 14:30 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-12-19 14:30 [COMMITTED] ada: Fix spurious visibility error on parent's component in instance 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).