diff mbox

[Ada] Support for discriminants in pragma Default_Initial_Condition

Message ID 20170425085722.GA47429@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet April 25, 2017, 8:57 a.m. UTC 
This patch augments the existing support for tagged discriminants in assertion
expressions such as those of pragma Default_Initial_Condition or Type_Invariant
'Class by adding support for ancestor subtypes.

------------
-- Source --
------------

--  tester.ads

package Tester is
   type Type_Id is
     (Deriv_1_Id,
      Deriv_2_Id,
      Deriv_3_Id,
      Deriv_4_Id,
      Deriv_5_Id,
      Deriv_6_Id,
      Deriv_7_Id,
      Deriv_8_Id,
      Deriv_9_Id,
      Deriv_10_Id,
      Deriv_11_Id,
      Par_1_Id,
      Par_2_Id,
      Par_3_Id,
      Par_4_Id,
      Par_5_Id,
      Par_6_Id,
      Par_7_Id,
      Par_8_Id,
      Par_9_Id,
      Par_10_Id,
      Par_11_Id);

   type Result is record
      X : Integer;
      Y : Integer;
   end record;

   No_Result : constant Result := (0, 0);

   type Results is array (Type_Id) of Result;

   procedure Mark (Id : Type_Id; X : Integer; Y : Integer);
   --  Record the result for a particular type

   procedure Reset_Results;
   --  Reset the internally kept result state

   procedure Test_Result (Test_Id : String; Exp : Results);
   --  Ensure that the internally kept result state agrees with expected
   --  results Exp. Emit an error if this is not the case.
end Tester;

--  tester.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Tester is
   State : Results;

   ----------
   -- Mark --
   ----------

   procedure Mark (Id : Type_Id; X : Integer; Y : Integer) is
   begin
      State (Id) := (X, Y);
   end Mark;

   -------------------
   -- Reset_Results --
   -------------------

   procedure Reset_Results is
   begin
      State := (others => No_Result);
   end Reset_Results;

   -----------------
   -- Test_Result --
   -----------------

   procedure Test_Result (Test_Id : String; Exp : Results) is
      Exp_Val   : Result;
      Posted    : Boolean := False;
      State_Val : Result;

   begin
      for Index in Results'Range loop
         Exp_Val   := Exp (Index);
         State_Val := State (Index);

         if State_Val /= Exp_Val then
            if not Posted then
               Posted := True;
               Put_Line (Test_Id & ": ERROR");
            end if;

            Put_Line
              ("  Index   : " & Index'Img);
            Put_Line
              ("  Expected:" & Exp_Val.X'Img & ',' & Exp_Val.Y'Img);
            Put_Line
              ("  Got     :" & State_Val.X'Img & ',' & State_Val.Y'Img);
         end if;
      end loop;

      if not Posted then
         Put_Line (Test_Id & ": OK");
      end if;
   end Test_Result;
end Tester;

--  dic_pack1.ads

package DIC_Pack1 is

   ---------------------------
   -- 1) Tagged derivations --
   ---------------------------

   --  No overriding
   --  Hidden derivation
   --  Subtype in the middle
   --  Subtype constrains

   type Par_1 (D_1 : Integer; D_2 : Integer) is tagged private
     with Default_Initial_Condition => A (Par_1, Par_1.D_1, D_2);

   function A (Obj : Par_1; X : Integer; Y : Integer) return Boolean;

   --  subtype Sub_1 is Par_1 (...);
   --  Par_1.D_1 constrained by 123
   --  Par_1.D_2 constrained by 456
   --  DIC calls: A (Par_1, 123, 456)

   type Deriv_1 is tagged private;
   --  DIC calls: A (Par_1, 123, 456)

   --  Overriding
   --  Hidden derivation
   --  Subtype in the middle
   --  Subtype constrains

   type Par_2 (D_1 : Integer; D_2 : Integer) is tagged private
     with Default_Initial_Condition => B (Par_2, Par_2.D_1, D_2);

   function B (Obj : Par_2; X : Integer; Y : Integer) return Boolean;

   --  subtype Sub_2 is Par_2 (...);
   --  Par_2.D_1 constrained by 123
   --  Par_2.D_2 constrained by 456
   --  DIC calls: B (Par_2, 123, 456)

   type Deriv_2 is tagged private;
   --  DIC calls: B (Deriv_2, 123, 456)

   function B (Obj : Deriv_2; X : Integer; Y : Integer) return Boolean;

   --  No overriding
   --  Hidden derivation
   --  Subtype in the middle
   --  Subtype renames

   type Par_3 (D_1 : Integer; D_2 : Integer) is tagged private
     with Default_Initial_Condition => C (Par_3, Par_3.D_1, D_2);

   function C (Obj : Par_3; X : Integer; Y : Integer) return Boolean;

   --  subtype Sub_3 is Par_3;
   --  inherits Par_3.D_1
   --  inherits Par_3.D_2
   --  DIC calls: C (Par_3, Sub_3.D_1, Sub_3.D_2)

   type Deriv_3 (D_3 : Integer; D_4 : Integer) is tagged private;
   --  Sub_3.D_1 constrained by 123
   --  Sub_3.D_2 renamed by Deriv_3.D_3
   --  DIC calls: C (Par_3, 123, Deriv_3.D_3)

   --  Overriding
   --  Hidden derivation
   --  Subtype in the middle
   --  Subtype renames

   type Par_4 (D_1 : Integer; D_2 : Integer) is tagged private
     with Default_Initial_Condition => D (Par_4, Par_4.D_1, D_2);

   function D (Obj : Par_4; X : Integer; Y : Integer) return Boolean;

   --  subtype Sub_4 is Par_4;
   --  inherits Par_4.D_1
   --  inherits Par_4.D_1
   --  DIC calls: D (Par_4, Sub_4.D_1, Sub_4.D_2)

   type Deriv_4 (D_3 : Integer; D_4 : Integer) is tagged private;
   --  Sub_4.D_1 renamed by D_4
   --  Sub_4.D_2 constrained by 456
   --  DIC calls: D (Deriv_4, Deriv_4.D_4, 456)

   --  Overriding
   --  Visible derivation
   --  Subtype last
   --  Subtype constrains

   type Par_5 (D_1 : Integer; D_2 : Integer) is tagged private
     with Default_Initial_Condition => E (Par_5, Par_5.D_1, D_2);

   function E (Obj : Par_5; X : Integer; Y : Integer) return Boolean;

   type Deriv_5 (D_3 : Integer; D_4 : Integer) is new Par_5 with private;
   --  Par_5.D_1 renamed by Deriv_5.D_4
   --  Par_5.D_2 renamed by Deriv_5.D_3
   --  DIC calls: E (Deriv_5, Deriv_5.D_4, Deriv_5.D_3)

   function E (Obj : Deriv_5; X : Integer; Y : Integer) return Boolean;

   --  subtype Sub_5 is Deriv_5 (...);
   --  Deriv_5.D_3 constrained by 123
   --  Deriv_5.D_4 constrained by 456
   --  DIC calls: E (Deriv_5, 456, 123)

   --  Overriding
   --  Hidden derivation
   --  Subtype last
   --  Subtype constrains

   type Par_6 (D_1 : Integer; D_2 : Integer) is tagged private
     with Default_Initial_Condition => F (Par_6, Par_6.D_1, D_2);

   function F (Obj : Par_6; X : Integer; Y : Integer) return Boolean;

   type Deriv_6 (D_3 : Integer; D_4 : Integer) is tagged private;
   --  Par_6.D_1 renamed by D_4
   --  Par_6.D_2 constrained by 123
   --  DIC calls: F (Deriv_6, Deriv_4.D_4, 123)

   --  subtype Sub_6 is Deriv_6;
   --  Deriv_6.D_3 constrained by 456
   --  Deriv_6.D_4 constrained by 789
   --  DIC calls: F (Deriv_6, 789, 123)

   --  Overriding
   --  Hidden derivation
   --  Multiple subtypes
   --  Subtypes constraint and rename

   type Par_7 (D_1 : Integer; D_2 : Integer) is tagged private
     with Default_Initial_Condition => G (Par_7, Par_7.D_1, D_2);

   function G (Obj : Par_7; X : Integer; Y : Integer) return Boolean;

   --  subtype Sub_7a is Par_7 (...);
   --  Par_7.D_1 constrained by 123
   --  Par_7.D_2 constrained by 456
   --  DIC calls: G (Par_7, 123, 456)

   --  subtype Sub_7b is Sub_7a;
   --  DIC calls: G (Par_7, 123, 456)

   type Deriv_7 (D_3 : Integer) is tagged private;
   --  DIC calls: G (Deriv_7, 123, 456)

   function G (Obj : Deriv_7; X : Integer; Y : Integer) return Boolean;

   -----------------------------
   -- 2) Untagged derivations --
   -----------------------------

   --  No overriding
   --  Hidden derivation
   --  Subtype in the middle
   --  Subtype constrans

   type Par_8 (D_1 : Integer; D_2 : Integer) is private
     with Default_Initial_Condition => H (Par_8, Par_8.D_1, D_2);

   function H (Obj : Par_8; X : Integer; Y : Integer) return Boolean;

   --  subtype Sub_8 is Par_8 (...);
   --  Par_8.D_1 constrained by 123
   --  Par_8.D_2 constrained by 456
   --  DIC calls: H (Par_8, 123, 456)

   type Deriv_8 is private;
   --  DIC calls: H (Par_8, 123, 456)

   --  No overriding
   --  Hidden derivation
   --  Subtype in the middle
   --  Subtype renames

   type Par_9 (D_1 : Integer; D_2 : Integer) is private
     with Default_Initial_Condition => I (Par_9, Par_9.D_1, D_2);
    
   function I (Obj : Par_9; X : Integer; Y : Integer) return Boolean;
    
   --  subtype Par_9 is Par_9;
   --  inherits Par_9.D_1
   --  inherits Par_9.D_2
   --  DIC calls: I (Par_9, Par_9.D_1, Par_9.D_2)

   type Deriv_9 (D_3 : Integer; D_4 : Integer) is private;
   --  Par_9.D_1 renamed by D_4
   --  Par_9.D_2 renamed by D_3
   --  DIC calls: C (Par_9, Deriv_9.D_4, Deriv_9.D_3)

   --  No overriding
   --  Hidden derivation
   --  Subtype last
   --  Subtype constrains

   type Par_10 (D_1 : Integer; D_2 : Integer) is private
     with Default_Initial_Condition => J (Par_10, Par_10.D_1, D_2);

   function J (Obj : Par_10; X : Integer; Y : Integer) return Boolean;

   type Deriv_10 (D_3 : Integer; D_4 : Integer) is private;
   --  Par_10.D_1 renamed by Deriv_10.D_4
   --  Par_10.D_2 renamed by Deriv_10.D_3
   --  DIC calls: J (Par_10, Deriv_10.D_4, Deriv_10.D_3)

   --  subtype Sub_10 is Deriv_10 (...);
   --  Deriv_10.D_3 constrained by 123
   --  Deriv_10.D_4 constrained by 456
   --  DIC calls: J (Par_10, 456, 123)

   --  No overriding
   --  Hidden derivation
   --  Subtype last
   --  Subtype renames

   type Par_11 (D_1 : Integer; D_2 : Integer) is private
     with Default_Initial_Condition => K (Par_11, Par_11.D_1, D_2);

   function K (Obj : Par_11; X : Integer; Y : Integer) return Boolean;

   type Deriv_11 (D_3 : Integer; D_4 : Integer) is private;
   --  Par_11.D_1 renamed by Deriv_11.D_4
   --  Par_11.D_2 renamed by Deriv_11.D_3
   --  DIC calls: K (Par_11, Deriv_11.D_4, Deriv_11.D_3)

   --  subtype Sub_11 is Deriv_11;
   --  inherits Deriv_11.D_3
   --  inherits Deriv_11.D_4
   --  DIC calls: K (Par_11, Deriv_11.D_4, Deriv_11.D_3)

   procedure Test_Deriv_2;
   procedure Test_Sub_1;
   procedure Test_Sub_2;
   procedure Test_Sub_3;
   procedure Test_Sub_4;
   procedure Test_Sub_5;
   procedure Test_Sub_6;
   procedure Test_Sub_7a;
   procedure Test_Sub_7b;
   procedure Test_Sub_8;
   procedure Test_Sub_9;
   procedure Test_Sub_10;
   procedure Test_Sub_11;

private
   Name : Integer := 123;

   type Par_1 (D_1 : Integer; D_2 : Integer) is tagged record
      Par_1_Comp : Integer;
   end record;

   subtype Sub_1 is Par_1 (Name, 456);

   type Deriv_1 is new Sub_1 with record
      Deriv_1_Comp : Integer;
   end record;

   type Par_2 (D_1 : Integer; D_2 : Integer) is tagged record
      Par_2_Comp : Integer;
   end record;

   subtype Sub_2 is Par_2 (Name, 456);

   type Deriv_2 is new Sub_2 with record
      Deriv_2_Comp : Integer;
   end record;

   type Par_3 (D_1 : Integer; D_2 : Integer) is tagged record
      Par_3_Comp : Integer;
   end record;

   subtype Sub_3 is Par_3;

   type Deriv_3 (D_3 : Integer; D_4 : Integer) is
     new Sub_3 (D_1 => 123, D_2 => D_3) with
   record
      Deriv_3_Comp : Integer;
   end record;

   type Par_4 (D_1 : Integer; D_2 : Integer) is tagged record
      Par_4_Comp : Integer;
   end record;

   subtype Sub_4 is Par_4;

   type Deriv_4 (D_3 : Integer; D_4 : Integer) is
     new Sub_4 (D_4, 456) with
   record
      Deriv_4_Comp : Integer;
   end record;

   function D (Obj : Deriv_4; X : Integer; Y : Integer) return Boolean;

   type Par_5 (D_1 : Integer; D_2 : Integer) is tagged record
      Par_5_Comp : Integer;
   end record;

   type Deriv_5 (D_3 : Integer; D_4 : Integer) is
     new Par_5 (D_4, D_3) with
   record
      Deriv_4_Comp : Integer;
   end record;

   subtype Sub_5 is Deriv_5 (Name, 456);

   type Par_6 (D_1 : Integer; D_2 : Integer) is tagged record
      Par_6_Comp : Integer;
   end record;

   type Deriv_6 (D_3 : Integer; D_4 : Integer) is
     new Par_6 (D_4, Name) with
   record
      Deriv_6_Comp : Integer;
   end record;

   function F (Obj : Deriv_6; X : Integer; Y : Integer) return Boolean;

   subtype Sub_6 is Deriv_6 (456, 789);

   type Par_7 (D_1 : Integer; D_2 : Integer) is tagged record
      Par_7_Comp : Integer;
   end record;

   subtype Sub_7a is Par_7 (Name, 456);
   subtype Sub_7b is Sub_7a;

   type Deriv_7 (D_3 : Integer) is new Sub_7b with record
      Deriv_7_Comp : Integer;
   end record;

   type Par_8 (D_1 : Integer; D_2 : Integer) is record
      Par_8_Comp : Integer;
   end record;

   subtype Sub_8 is Par_8 (Name, 456);

   type Deriv_8 is new Sub_8;

   type Par_9 (D_1 : Integer; D_2 : Integer) is record
      Par_9_Comp : Integer;
   end record;

   subtype Sub_9 is Par_9;

   type Deriv_9 (D_3 : Integer; D_4 : Integer) is new Sub_9 (D_4, D_3);

   type Par_10 (D_1 : Integer; D_2 : Integer) is record
      Par_10_Comp : Integer;
   end record;

   type Deriv_10 (D_3 : Integer; D_4 : Integer) is new Par_10 (D_4, D_3);

   subtype Sub_10 is Deriv_10 (Name, 456);

   type Par_11 (D_1 : Integer; D_2 : Integer) is record
      Par_11_Comp : Integer;
   end record;

   type Deriv_11 (D_3 : Integer; D_4 : Integer) is new Par_11 (D_4, D_3);

   subtype Sub_11 is Deriv_11;
end DIC_Pack1;

--  dic_pack1.adb

with Tester; use Tester;

package body DIC_Pack1 is
   function A (Obj : Par_1; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_1_Id, X, Y);
      return True;
   end A;

   function B (Obj : Par_2; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_2_Id, X, Y);
      return True;
   end B;

   function B (Obj : Deriv_2; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Deriv_2_Id, X, Y);
      return True;
   end B;

   function C (Obj : Par_3; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_3_Id, X, Y);
      return True;
   end C;

   function D (Obj : Par_4; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_4_Id, X, Y);
      return True;
   end D;

   function D (Obj : Deriv_4; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Deriv_4_Id, X, Y);
      return True;
   end D;

   function E (Obj : Par_5; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_5_Id, X, Y);
      return True;
   end E;

   function E (Obj : Deriv_5; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Deriv_5_Id, X, Y);
      return True;
   end E;

   function F (Obj : Par_6; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_6_Id, X, Y);
      return True;
   end F;

   function F (Obj : Deriv_6; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Deriv_6_Id, X, Y);
      return True;
   end F;

   function G (Obj : Par_7; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_7_Id, X, Y);
      return True;
   end G;

   function G (Obj : Deriv_7; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Deriv_7_Id, X, Y);
      return True;
   end G;

   function H (Obj : Par_8; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_8_Id, X, Y);
      return True;
   end H;

   function I (Obj : Par_9; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_9_Id, X, Y);
      return True;
   end I;

   function J (Obj : Par_10; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_10_Id, X, Y);
      return True;
   end J;

   function K (Obj : Par_11; X : Integer; Y : Integer) return Boolean is
   begin
      Mark (Par_11_Id, X, Y);
      return True;
   end K;

   procedure Test_Deriv_2 is
      Obj : Deriv_2;
   begin null; end Test_Deriv_2;

   procedure Test_Sub_1 is
      Obj : Sub_1;
   begin null; end Test_Sub_1;

   procedure Test_Sub_2 is
      Obj : Sub_2;
   begin null; end Test_Sub_2;

   procedure Test_Sub_3 is
      Obj : Sub_3 (3, 33);
   begin null; end Test_Sub_3;

   procedure Test_Sub_4 is
      Obj : Sub_4 (4, 44);
   begin null; end Test_Sub_4;

   procedure Test_Sub_5 is
      Obj : Sub_5;
   begin null; end Test_Sub_5;

   procedure Test_Sub_6 is
      Obj : Sub_6;
   begin null; end Test_Sub_6;

   procedure Test_Sub_7a is
      Obj : Sub_7a;
   begin null; end Test_Sub_7a;

   procedure Test_Sub_7b is
      Obj : Sub_7b;
   begin null; end Test_Sub_7b;

   procedure Test_Sub_8 is
      Obj : Sub_8;
   begin null; end Test_Sub_8;

   procedure Test_Sub_9 is
      Obj : Sub_9 (9, 99);
   begin null; end Test_Sub_9;

   procedure Test_Sub_10 is
      Obj : Sub_10;
   begin null; end Test_Sub_10;

   procedure Test_Sub_11 is
      Obj : Sub_11 (11, 1111);
   begin null; end Test_Sub_11;
end DIC_Pack1;

--  dic_pack2.ads

with DIC_Pack1; use DIC_Pack1;

package DIC_Pack2 is
   Name : Integer := 123;

   ---------------------------
   -- 1) Tagged derivations --
   ---------------------------

   subtype Sub_12 is Par_1 (Name, 456);
   --  Par_1.D_1 constrained by 123
   --  Par_1.D_2 constrained by 456
   --  DIC calls: A (Par_1, 123, 456)

   subtype Sub_13 is Deriv_1;
   --  DIC calls: A (Par_1, 123, 456)

   subtype Sub_14 is Par_2 (456, Name);
   --  Par_2.D_1 constrained by 456
   --  Par_2.D_2 constrained by 123
   --  DIC calls: B (Par_2, 456, 123)

   subtype Sub_15 is Deriv_2;
   --  DIC calls: B (Deriv_2, 123, 456)

   subtype Sub_16 is Par_3;
   --  inherits Par_3.D_1
   --  inherits Par_3.D_2
   --  DIC calls: C (Par_3, Sub_16.D_1, Sub_16.D_2)

   subtype Sub_17 is Deriv_3;
   --  Par_3.D_1 constrained by 123
   --  Par_3.D_2 renamed by Sub_17.D_3
   --  DIC calls: C (Par_3, 123, Sub_17.D_3)

   subtype Sub_18 is Deriv_4;
   --  inherits Deriv_3.D_3
   --  inherits Deriv_4.D_4
   --  DIC calls: D (Deriv_4, Sub_18.D_4, 456)

   subtype Sub_19 is Deriv_5 (Name, 456);
   --  Deriv_4.D_3 constrained by 123
   --  Deriv_4.D_4 constrained by 456
   --  DIC calls: E (Deriv_5, 456, 123)

   subtype Sub_20 is Deriv_6 (456, Name);
   --  inherits Deriv_6.D_3
   --  Deriv_6.D_4 constrained by 123
   --  DIC calls: F (Deriv_6, 123, 123)

   subtype Sub_21 is Deriv_7;
   --  inherits Deriv_7.D_3
   --  DIC calls: G (Deriv_7, 123, 456)

   subtype Sub_22 is Par_8 (Name, 456);
   --  Par_8.D_1 constrained by 123
   --  Par_8.D_2 constrained by 456
   --  DIC calls: H (Par_8, 123, 456)

   subtype Sub_23 is Deriv_8;
   --  DIC calls: H (Par_8, 123, 456)

   subtype Sub_24 is Deriv_9 (Name, 456);
   --  Deriv_9.D_3 constrained by 123
   --  Deriv_9.D_4 constrained by 456
   --  DIC calls: I (Par_9, 456, 123)

   subtype Sub_25 is Deriv_10;
   --  inherits Deriv_10.D_3
   --  inherits Deriv_10.D_4
   --  DIC calls: J (Par_10, Sub_25.D_4, Sub_25.D_3)

   subtype Sub_26 is Deriv_11 (456, Name);
   --  Deriv_11.D_3 constrained by 456
   --  Deriv_11.D_4 constrained by 123
   --  DIC calls: K (Par_11, 123, 456)
end DIC_Pack2;

--  dic_main.adb

with DIC_Pack1; use DIC_Pack1;
with DIC_Pack2; use DIC_Pack2;
with Tester;    use Tester;

procedure DIC_Main is
begin
   Reset_Results;
   Test_Sub_1;
   Test_Result ("Sub_1", (Par_1_Id => (123, 456),
                          others   => No_Result));

   Reset_Results;
   declare
      Obj : Deriv_1;
   begin
      Test_Result ("Deriv_1", (Par_1_Id => (123, 456),
                               others   => No_Result));
   end;

   Reset_Results;
   Test_Sub_2;
   Test_Result ("Sub_2", (Par_2_Id => (123, 456),
                          others   => No_Result));

   Reset_Results;
   Test_Deriv_2;
   Test_Result ("Deriv_2", (Deriv_2_Id => (123, 456),
                            others     => No_Result));

   Reset_Results;
   Test_Sub_3;
   Test_Result ("Sub_3", (Par_3_Id => (3, 33),
                          others   => No_Result));

   Reset_Results;
   declare
      Obj : Deriv_3 (3, 33);
   begin
      Test_Result ("Deriv_3", (Par_3_Id => (123, 3),
                               others   => No_Result));
   end;

   Reset_Results;
   Test_Sub_4;
   Test_Result ("Sub_4", (Par_4_Id => (4, 44),
                          others   => No_Result));

   Reset_Results;
   declare
      Obj : Deriv_4 (4, 44);
   begin
      Test_Result ("Deriv_4", (Deriv_4_Id => (44, 456),
                               others     => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Deriv_5 (5, 55);
   begin
      Test_Result ("Deriv_5", (Deriv_5_Id => (55, 5),
                               others     => No_Result));
   end;

   Reset_Results;
   Test_Sub_5;
   Test_Result ("Sub_5", (Deriv_5_Id => (456, 123),
                          others     => No_Result));

   Reset_Results;
   declare
      Obj : Deriv_6 (6, 66);
   begin
      Test_Result ("Deriv_6", (Deriv_6_Id => (66, 123),
                               others     => No_Result));
   end;

   Reset_Results;
   Test_Sub_6;
   Test_Result ("Sub_6", (Deriv_6_Id => (789, 123),
                          others     => No_Result));

   Reset_Results;
   Test_Sub_7a;
   Test_Result ("Sub_7a", (Par_7_Id => (123, 456),
                           others   => No_Result));

   Reset_Results;
   Test_Sub_7b;
   Test_Result ("Sub_7b", (Par_7_Id => (123, 456),
                           others   => No_Result));

   Reset_Results;
   declare
      Obj : Deriv_7 (7);
   begin
      Test_Result ("Deriv_7", (Deriv_7_Id => (123, 456),
                               others     => No_Result));
   end;

   Reset_Results;
   Test_Sub_8;
   Test_Result ("Sub_8", (Par_8_Id => (123, 456),
                          others   => No_Result));

   Reset_Results;
   declare
      Obj : Deriv_8;
   begin
      Test_Result ("Deriv_8", (Par_8_Id => (123, 456),
                               others   => No_Result));
   end;

   Reset_Results;
   Test_Sub_9;
   Test_Result ("Sub_9", (Par_9_Id => (9, 99),
                          others   => No_Result));

   Reset_Results;
   declare
      Obj : Deriv_9 (9, 99);
   begin
      Test_Result ("Deriv_9", (Par_9_Id => (99, 9),
                               others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Deriv_10 (10, 1010);
   begin
      Test_Result ("Deriv_10", (Par_10_Id => (1010, 10),
                                others    => No_Result));
   end;

   Reset_Results;
   Test_Sub_10;
   Test_Result ("Sub_10", (Par_10_Id => (456, 123),
                           others    => No_Result));

   Reset_Results;
   declare
      Obj : Deriv_11 (11, 1111);
   begin
      Test_Result ("Deriv_11", (Par_11_Id => (1111, 11),
                                others    => No_Result));
   end;

   Reset_Results;
   Test_Sub_11;
   Test_Result ("Sub_11", (Par_11_Id => (1111, 11),
                           others    => No_Result));

   Reset_Results;
   declare
      Obj : Sub_12;
   begin
      Test_Result ("Sub_12", (Par_1_Id => (123, 456),
                              others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_13;
   begin
      Test_Result ("Sub_13", (Par_1_Id => (123, 456),
                              others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_14;
   begin
      Test_Result ("Sub_14", (Par_2_Id => (456, 123),
                              others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_15;
   begin
      Test_Result ("Sub_15", (Deriv_2_Id => (123, 456),
                              others     => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_16 (16, 1616);
   begin
      Test_Result ("Sub_16", (Par_3_Id => (16, 1616),
                              others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_17 (17, 1717);
   begin
      Test_Result ("Sub_17", (Par_3_Id => (123, 17),
                              others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_18 (18, 1818);
   begin
      Test_Result ("Sub_18", (Deriv_4_Id => (1818, 456),
                              others     => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_19;
   begin
      Test_Result ("Sub_19", (Deriv_5_Id => (456, 123),
                              others     => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_20;
   begin
      Test_Result ("Sub_20", (Deriv_6_Id => (123, 123),
                              others     => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_21 (21);
   begin
      Test_Result ("Sub_21", (Deriv_7_Id => (123, 456),
                              others     => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_22;
   begin
      Test_Result ("Sub_22", (Par_8_Id => (123, 456),
                              others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_23;
   begin
      Test_Result ("Sub_23", (Par_8_Id => (123, 456),
                              others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_24;
   begin
      Test_Result ("Sub_24", (Par_9_Id => (456, 123),
                              others   => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_25 (25, 2525);
   begin
      Test_Result ("Sub_25", (Par_10_Id => (2525, 25),
                              others    => No_Result));
   end;

   Reset_Results;
   declare
      Obj : Sub_26;
   begin
      Test_Result ("Sub_26", (Par_11_Id => (123, 456),
                              others    => No_Result));
   end;
end DIC_Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q -gnata -gnatws dic_main.adb
$ ./dic_main
Sub_1: OK
Deriv_1: OK
Sub_2: OK
Deriv_2: OK
Sub_3: OK
Deriv_3: OK
Sub_4: OK
Deriv_4: OK
Deriv_5: OK
Sub_5: OK
Deriv_6: OK
Sub_6: OK
Sub_7a: OK
Sub_7b: OK
Deriv_7: OK
Sub_8: OK
Deriv_8: OK
Sub_9: OK
Deriv_9: OK
Deriv_10: OK
Sub_10: OK
Deriv_11: OK
Sub_11: OK
Sub_12: OK
Sub_13: OK
Sub_14: OK
Sub_15: OK
Sub_16: OK
Sub_17: OK
Sub_18: OK
Sub_19: OK
Sub_20: OK
Sub_21: OK
Sub_22: OK
Sub_23: OK
Sub_24: OK
Sub_25: OK
Sub_26: OK

Tested on x86_64-pc-linux-gnu, committed on trunk

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_util.adb (Build_Chain): Account for ancestor
	subtypes while traversing the derivation chain.
diff mbox

Patch

Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 247148)
+++ exp_util.adb	(working copy)
@@ -8230,17 +8230,45 @@ 
 
          Curr_Typ := Deriv_Typ;
          loop
-            --  Work with the view which contains the discriminants and stored
-            --  constraints.
+            --  Handle the case where the current type is a record which
+            --  derives from a subtype.
 
-            Anc_Typ := Discriminated_View (Base_Type (Etype (Curr_Typ)));
+            --    subtype Sub_Typ is Par_Typ ...
+            --    type Deriv_Typ is Sub_Typ ...
 
-            --  Use the first subtype when dealing with base types
+            if Ekind (Curr_Typ) = E_Record_Type
+              and then Present (Parent_Subtype (Curr_Typ))
+            then
+               Anc_Typ := Parent_Subtype (Curr_Typ);
 
+            --  Handle the case where the current type is a record subtype of
+            --  another subtype.
+
+            --    subtype Sub_Typ1 is Par_Typ ...
+            --    subtype Sub_Typ2 is Sub_Typ1 ...
+
+            elsif Ekind (Curr_Typ) = E_Record_Subtype
+              and then Present (Cloned_Subtype (Curr_Typ))
+            then
+               Anc_Typ := Cloned_Subtype (Curr_Typ);
+
+            --  Otherwise use the direct parent type
+
+            else
+               Anc_Typ := Etype (Curr_Typ);
+            end if;
+
+            --  Use the first subtype when dealing with itypes
+
             if Is_Itype (Anc_Typ) then
                Anc_Typ := First_Subtype (Anc_Typ);
             end if;
 
+            --  Work with the view which contains the discriminants and stored
+            --  constraints.
+
+            Anc_Typ := Discriminated_View (Anc_Typ);
+
             --  Stop the climb when either the parent type has been reached or
             --  there are no more ancestors left to examine.