diff mbox series

[Ada] Spurious errors on derived untagged types with partial constraints

Message ID 20170906095452.GA79470@adacore.com
State New
Headers show
Series [Ada] Spurious errors on derived untagged types with partial constraints | expand

Commit Message

Arnaud Charlet Sept. 6, 2017, 9:54 a.m. UTC
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.
diff mbox series

Patch

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;