===================================================================
@@ -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;
This patch fixes the handling of untagged discriminated derived types that constrain some parent discriminants and rename others. The compiler failed to handle a change of representation on the derived type, and generated faulty code for the initialization procedure or such a derived type. Executing: --- gnatmake -q p p -- must yield: -- 1234 TRUE 20 discriminant rules!! --- with Q; use Q; with Text_IO; use Text_IO; procedure P is procedure Inner (B : Base) is begin null; -- Put_Line (B.S); Put_Line (Integer'Image (B.I)); Put_Line (Boolean'Image (B.B)); Put_Line (Integer'Image (B.D)); Put_Line (B.S); end; D1 : Derived (True); begin D1.S := "discriminant rules!!"; Inner (Base (D1)); end; --- package Q is type Base (D : Positive; B : Boolean) is record I : Integer := 1234; S : String (1 .. D); -- := (1 .. D => 'Q'); end record; type Derived (B : Boolean) is new Base (D => 20, B => B); for Derived use record I at 0 range 0 .. 31; end record; Thing : Derived (False); end Q; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg <schonberg@adacore.com> * exp_ch4.adb (Handle_Changed_Representation): For an untagged derived type with a mixture of renamed and constrained parent discriminants, the constraint for the target must obtain the discriminant values from both the operand and from the stored constraint for it, given that the constrained discriminants are not visible in the object. * exp_ch5.adb (Make_Field_Assign): The type of the right-hand side may be derived from that of the left-hand side (as in the case of an assignment with a change of representation) so the discriminant to be used in the retrieval of the value of the component must be the entity in the type of the right-hand side.