===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1448,9 +1448,21 @@
U_U : Boolean := False) return Node_Id
is
A : Node_Id;
+ Disc : Entity_Id;
Expr : Node_Id;
begin
+
+ -- The discriminant entity to be used in the retrieval below must
+ -- be one in the corresponding type, given that the assignment
+ -- may be between derived and parent types.
+
+ if Is_Derived_Type (Etype (Rhs)) then
+ Disc := Find_Component (R_Typ, C);
+ else
+ Disc := C;
+ end if;
+
-- In the case of an Unchecked_Union, use the discriminant
-- constraint value as on the right-hand side of the assignment.
@@ -1463,7 +1475,7 @@
Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name => New_Occurrence_Of (C, Loc));
+ Selector_Name => New_Occurrence_Of (Disc, Loc));
end if;
A :=
===================================================================
@@ -10627,7 +10627,6 @@
Temp : Entity_Id;
Decl : Node_Id;
Odef : Node_Id;
- Disc : Node_Id;
N_Ix : Node_Id;
Cons : List_Id;
@@ -10657,23 +10656,70 @@
if not Is_Constrained (Target_Type) then
if Has_Discriminants (Operand_Type) then
- Disc := First_Discriminant (Operand_Type);
- if Disc /= First_Stored_Discriminant (Operand_Type) then
- Disc := First_Stored_Discriminant (Operand_Type);
- end if;
+ -- A change of representation can only apply to untagged
+ -- types. We need to build the constraint that applies to
+ -- the target type, using the constraints of the operand.
+ -- The analysis is complicated if there are both inherited
+ -- discriminants and constrained discriminants.
+ -- We iterate over the discriminants of the target, and
+ -- find the discriminant of the same name:
- Cons := New_List;
- while Present (Disc) loop
- Append_To (Cons,
- Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr_Move_Checks (Operand),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Disc))));
- Next_Discriminant (Disc);
- end loop;
+ -- a) If there is a corresponding discriminant in the object
+ -- then the value is a selected component of the operand.
+ -- b) Otherwise the value of a constrained discriminant is
+ -- found in the stored constraint of the operand.
+
+ declare
+ Stored : constant Elist_Id :=
+ Stored_Constraint (Operand_Type);
+
+ Elmt : Elmt_Id;
+
+ Disc_O : Entity_Id;
+ -- Discriminant of the operand type. Its value in the
+ -- the object is captured in a selected component.
+
+ Disc_S : Entity_Id;
+ -- Stored discriminant of the operand. If present, it
+ -- corresponds to a constrained discriminant of the
+ -- parent type.
+
+ Disc_T : Entity_Id;
+ -- Discriminant of the target type
+
+ begin
+ Disc_T := First_Discriminant (Target_Type);
+ Disc_O := First_Discriminant (Operand_Type);
+ Disc_S := First_Stored_Discriminant (Operand_Type);
+
+ if Present (Stored) then
+ Elmt := First_Elmt (Stored);
+ end if;
+
+ Cons := New_List;
+ while Present (Disc_T) loop
+ if Present (Disc_O)
+ and then Chars (Disc_T) = Chars (Disc_O)
+ then
+ Append_To (Cons,
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Duplicate_Subexpr_Move_Checks (Operand),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Disc_O))));
+ Next_Discriminant (Disc_O);
+
+ elsif Present (Disc_S) then
+ Append_To (Cons, New_Copy_Tree (Node (Elmt)));
+ Next_Elmt (Elmt);
+ end if;
+
+ Next_Discriminant (Disc_T);
+ end loop;
+ end;
+
elsif Is_Array_Type (Operand_Type) then
N_Ix := First_Index (Target_Type);
Cons := New_List;