-- 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
-- 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.
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 --
--------------------------
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 --
-----------------------
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).