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 <kirtc...@adacore.com>
* exp_util.adb (Build_Chain): Account for ancestor
subtypes while traversing the derivation chain.
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.
