Lhs : Node_Id;
Res : List_Id;
- function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
- -- Analysis of the aggregate has replaced discriminants by their
- -- corresponding discriminals, but these are irrelevant when the
- -- component has a mutable type and is initialized with an aggregate.
- -- Instead, they must be replaced by the values supplied in the
- -- aggregate, that will be assigned during the expansion of the
- -- assignment.
-
- -----------------------
- -- Replace_Discr_Ref --
- -----------------------
-
- function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
- Val : Node_Id;
-
- begin
- if Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Is_Formal (Entity (N))
- and then Present (Discriminal_Link (Entity (N)))
- then
- Val :=
- Make_Selected_Component (Default_Loc,
- Prefix => New_Copy_Tree (Lhs),
- Selector_Name =>
- New_Occurrence_Of
- (Discriminal_Link (Entity (N)), Default_Loc));
-
- if Present (Val) then
- Rewrite (N, New_Copy_Tree (Val));
- end if;
- end if;
-
- return OK;
- end Replace_Discr_Ref;
-
- procedure Replace_Discriminant_References is
- new Traverse_Proc (Replace_Discr_Ref);
-
- -- Start of processing for Build_Assignment
-
begin
Lhs :=
Make_Selected_Component (Default_Loc,
Selector_Name => New_Occurrence_Of (Id, Default_Loc));
Set_Assignment_OK (Lhs);
- if Nkind (Exp) = N_Aggregate
- and then Has_Discriminants (Typ)
- and then not Is_Constrained (Base_Type (Typ))
- then
- -- The aggregate may provide new values for the discriminants
- -- of the component, and other components may depend on those
- -- discriminants. Previous analysis of those expressions have
- -- replaced the discriminants by the formals of the initialization
- -- procedure for the type, but these are irrelevant in the
- -- enclosing initialization procedure: those discriminant
- -- references must be replaced by the values provided in the
- -- aggregate.
-
- Replace_Discriminant_References (Exp);
- end if;
-
-- Case of an access attribute applied to the current instance.
-- Replace the reference to the type by a reference to the actual
-- object. (Note that this handles the case of the top level of