public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-5913] ada: Errors on instance of Multiway_Trees with discriminated type
@ 2023-11-28 9:38 Marc Poulhi?s
0 siblings, 0 replies; only message in thread
From: Marc Poulhi?s @ 2023-11-28 9:38 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:1a2f4e332c0bca0b6665921c38be9c9f1c04e0b4
commit r14-5913-g1a2f4e332c0bca0b6665921c38be9c9f1c04e0b4
Author: Gary Dismukes <dismukes@adacore.com>
Date: Wed Nov 15 23:57:47 2023 +0000
ada: Errors on instance of Multiway_Trees with discriminated type
The compiler may report various type conflicts on an instantiation
of the generic package Ada.Containers.Multiway_Trees with an actual
for Element_Type that is a nonprivate actual type with discriminants
that has a discriminant-dependent component of a private type (such
as a Bounded_Vector type). The type errors occur on an aggregate
of the implementation type Tree_Node_Type within the body of
Multiway_Trees, where the aggregate has a box-defaulted association
for the Element component. (Such type errors could of course arise
in other cases of generic instantiations that follow a similar type
model.)
In the case where the discriminant-dependent component type has a
default-initialization procedure (init proc), the compiler was handling
box associations for such components by expanding the topmost box
association into subaggregates that themselves have box associations,
and didn't properly account for discriminant-dependent subcomponents of
private types. This could be fixed internally in Propagate_Discriminants,
but it seems that the entire machinery for dealing with such subcomponent
associations is unnecessary, and the topmost component association can
be handled directly as a default-initialized box association.
gcc/ada/
* sem_aggr.adb (Add_Discriminant_Values): Remove this procedure.
(Propagate_Discriminants): Remove this procedure.
(Resolve_Record_Aggregate): Remove code (the Capture_Discriminants
block statement) related to propagating discriminants and
generating initializations for subcomponents of a
discriminant-dependent box-defaulted subcomponent of a nonprivate
record type with discriminants, and handle all top-level
components that have a non-null base init proc directly, by
calling Add_Association with "Is_Box_Present => True". Also,
combine that elsif clause with the immediately preceding elsif
clause, since they now both contain the same statement (calls to
Add_Association with the same actuals).
Diff:
---
gcc/ada/sem_aggr.adb | 274 +--------------------------------------------------
1 file changed, 4 insertions(+), 270 deletions(-)
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index bc03a079f5a..e1e7b8bac37 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -4623,14 +4623,6 @@ package body Sem_Aggr is
-- either New_Assoc_List, or the association being built for an inner
-- aggregate.
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id);
- -- The constraint to a component may be given by a discriminant of the
- -- enclosing type, in which case we have to retrieve its value, which is
- -- part of the enclosing aggregate. Assoc_List provides the discriminant
- -- associations of the current type or of some enclosing record.
-
function Discriminant_Present (Input_Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True.
-- Otherwise, if N is an extension aggregate, then Input_Discr denotes
@@ -4673,13 +4665,6 @@ package body Sem_Aggr is
-- An error message is emitted if the components taking their value from
-- the others choice do not have same type.
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id);
- -- Nested components may themselves be discriminated types constrained
- -- by outer discriminants, whose values must be captured before the
- -- aggregate is expanded into assignments.
-
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id);
-- Analyzes and resolves expression Expr against the Etype of the
-- Component. This routine also applies all appropriate checks to Expr.
@@ -4736,73 +4721,6 @@ package body Sem_Aggr is
end if;
end Add_Association;
- -----------------------------
- -- Add_Discriminant_Values --
- -----------------------------
-
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Assoc : Node_Id;
- Discr : Entity_Id;
- Discr_Elmt : Elmt_Id;
- Discr_Val : Node_Id;
- Val : Entity_Id;
-
- begin
- Discr := First_Discriminant (Etype (New_Aggr));
- Discr_Elmt := First_Elmt (Discriminant_Constraint (Etype (New_Aggr)));
- while Present (Discr_Elmt) loop
- Discr_Val := Node (Discr_Elmt);
-
- -- If the constraint is given by a discriminant then it is a
- -- discriminant of an enclosing record, and its value has already
- -- been placed in the association list.
-
- if Is_Entity_Name (Discr_Val)
- and then Ekind (Entity (Discr_Val)) = E_Discriminant
- then
- Val := Entity (Discr_Val);
-
- Assoc := First (Assoc_List);
- while Present (Assoc) loop
- if Present (Entity (First (Choices (Assoc))))
- and then Entity (First (Choices (Assoc))) = Val
- then
- Discr_Val := Expression (Assoc);
- exit;
- end if;
-
- Next (Assoc);
- end loop;
- end if;
-
- Add_Association
- (Discr, New_Copy_Tree (Discr_Val),
- Component_Associations (New_Aggr));
-
- -- If the discriminant constraint is a current instance, mark the
- -- current aggregate so that the self-reference can be expanded by
- -- Build_Record_Aggr_Code.Replace_Type later.
-
- if Nkind (Discr_Val) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Discr_Val))
- and then Is_Type (Entity (Prefix (Discr_Val)))
- and then
- Is_Ancestor
- (Entity (Prefix (Discr_Val)),
- Etype (N),
- Use_Full_View => True)
- then
- Set_Has_Self_Reference (N);
- end if;
-
- Next_Elmt (Discr_Elmt);
- Next_Discriminant (Discr);
- end loop;
- end Add_Discriminant_Values;
-
--------------------------
-- Discriminant_Present --
--------------------------
@@ -5126,99 +5044,6 @@ package body Sem_Aggr is
return Expr;
end Get_Value;
- -----------------------------
- -- Propagate_Discriminants --
- -----------------------------
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Loc : constant Source_Ptr := Sloc (N);
-
- procedure Process_Component (Comp : Entity_Id);
- -- Add one component with a box association to the inner aggregate,
- -- and recurse if component is itself composite.
-
- -----------------------
- -- Process_Component --
- -----------------------
-
- procedure Process_Component (Comp : Entity_Id) is
- T : constant Entity_Id := Etype (Comp);
- New_Aggr : Node_Id;
-
- begin
- if Is_Record_Type (T) and then Has_Discriminants (T) then
- New_Aggr := Make_Aggregate (Loc, No_List, New_List);
- Set_Etype (New_Aggr, T);
-
- Add_Association
- (Comp, New_Aggr, Component_Associations (Aggr));
-
- -- Collect discriminant values and recurse
-
- Add_Discriminant_Values (New_Aggr, Assoc_List);
- Propagate_Discriminants (New_Aggr, Assoc_List);
-
- Build_Constrained_Itype
- (New_Aggr, T, Component_Associations (New_Aggr));
- else
- Add_Association
- (Comp, Empty, Component_Associations (Aggr),
- Is_Box_Present => True);
- end if;
- end Process_Component;
-
- -- Local variables
-
- Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr));
- Components : constant Elist_Id := New_Elmt_List;
- Def_Node : constant Node_Id :=
- Type_Definition (Declaration_Node (Aggr_Type));
-
- Comp : Node_Id;
- Comp_Elmt : Elmt_Id;
- Errors : Boolean;
-
- -- Start of processing for Propagate_Discriminants
-
- begin
- -- The component type may be a variant type. Collect the components
- -- that are ruled by the known values of the discriminants. Their
- -- values have already been inserted into the component list of the
- -- current aggregate.
-
- if Nkind (Def_Node) = N_Record_Definition
- and then Present (Component_List (Def_Node))
- and then Present (Variant_Part (Component_List (Def_Node)))
- then
- Gather_Components (Aggr_Type,
- Component_List (Def_Node),
- Governed_By => Component_Associations (Aggr),
- Into => Components,
- Report_Errors => Errors);
-
- Comp_Elmt := First_Elmt (Components);
- while Present (Comp_Elmt) loop
- if Ekind (Node (Comp_Elmt)) /= E_Discriminant then
- Process_Component (Node (Comp_Elmt));
- end if;
-
- Next_Elmt (Comp_Elmt);
- end loop;
-
- -- No variant part, iterate over all components
-
- else
- Comp := First_Component (Etype (Aggr));
- while Present (Comp) loop
- Process_Component (Comp);
- Next_Component (Comp);
- end loop;
- end if;
- end Propagate_Discriminants;
-
-----------------------
-- Resolve_Aggr_Expr --
-----------------------
@@ -6074,107 +5899,16 @@ package body Sem_Aggr is
Assoc_List => New_Assoc_List);
Set_Has_Self_Reference (N);
- elsif Needs_Simple_Initialization (Ctyp) then
+ elsif Needs_Simple_Initialization (Ctyp)
+ or else Has_Non_Null_Base_Init_Proc (Ctyp)
+ or else not Expander_Active
+ then
Add_Association
(Component => Component,
Expr => Empty,
Assoc_List => New_Assoc_List,
Is_Box_Present => True);
- elsif Has_Non_Null_Base_Init_Proc (Ctyp)
- or else not Expander_Active
- then
- if Is_Record_Type (Ctyp)
- and then Has_Discriminants (Ctyp)
- and then not Is_Private_Type (Ctyp)
- then
- -- We build a partially initialized aggregate with the
- -- values of the discriminants and box initialization
- -- for the rest, if other components are present.
-
- -- The type of the aggregate is the known subtype of
- -- the component. The capture of discriminants must be
- -- recursive because subcomponents may be constrained
- -- (transitively) by discriminants of enclosing types.
- -- For a private type with discriminants, a call to the
- -- initialization procedure will be generated, and no
- -- subaggregate is needed.
-
- Capture_Discriminants : declare
- Loc : constant Source_Ptr := Sloc (N);
- Expr : Node_Id;
-
- begin
- Expr := Make_Aggregate (Loc, No_List, New_List);
- Set_Etype (Expr, Ctyp);
-
- -- If the enclosing type has discriminants, they have
- -- been collected in the aggregate earlier, and they
- -- may appear as constraints of subcomponents.
-
- -- Similarly if this component has discriminants, they
- -- might in turn be propagated to their components.
-
- if Has_Discriminants (Typ) then
- Add_Discriminant_Values (Expr, New_Assoc_List);
- Propagate_Discriminants (Expr, New_Assoc_List);
-
- elsif Has_Discriminants (Ctyp) then
- Add_Discriminant_Values
- (Expr, Component_Associations (Expr));
- Propagate_Discriminants
- (Expr, Component_Associations (Expr));
-
- Build_Constrained_Itype
- (Expr, Ctyp, Component_Associations (Expr));
-
- else
- declare
- Comp : Entity_Id;
-
- begin
- -- If the type has additional components, create
- -- an OTHERS box association for them.
-
- Comp := First_Component (Ctyp);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component then
- if not Is_Record_Type (Etype (Comp)) then
- Append_To
- (Component_Associations (Expr),
- Make_Component_Association (Loc,
- Choices =>
- New_List (
- Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True));
- end if;
-
- exit;
- end if;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
- Add_Association
- (Component => Component,
- Expr => Expr,
- Assoc_List => New_Assoc_List);
- end Capture_Discriminants;
-
- -- Otherwise the component type is not a record, or it has
- -- not discriminants, or it is private.
-
- else
- Add_Association
- (Component => Component,
- Expr => Empty,
- Assoc_List => New_Assoc_List,
- Is_Box_Present => True);
- end if;
-
-- Otherwise we only need to resolve the expression if the
-- component has partially initialized values (required to
-- expand the corresponding assignments and run-time checks).
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-11-28 9:38 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-11-28 9:38 [gcc r14-5913] ada: Errors on instance of Multiway_Trees with discriminated type 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).