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 <schonb...@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.
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 251753)
+++ exp_ch5.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- 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 :=
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 251758)
+++ exp_ch4.adb (working copy)
@@ -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;
