This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
This patch adds support for tagged discriminants in assertion expressions such as those of pragma Default_Initial_Condition or Type_Invariant'Class. In these contexts, tagged discriminants behave as primitives and exhibit "overriding"- like properties. For instance, if a derived type constrains its parent and inherits a Default_Initial_Condition from it which checks the discriminant of the parent, the runtime check must verify the discriminant of the derived type. ------------ -- Source -- ------------ -- tester.ads package Tester is type Type_Id is (No_Type, 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, Deriv_12_Id, Deriv_13_Id, Deriv_14_Id, Deriv_15_Id, Deriv_16_Id, Deriv_17_Id, Deriv_18_Id, Deriv_19_Id, Deriv_20_Id, Deriv_21_Id, Deriv_22_Id, Deriv_23_Id, Deriv_24_Id, Deriv_25_Id, Deriv_26_Id, Deriv_27_Id, Deriv_28_Id, Deriv_29_Id, Deriv_30_Id, Deriv_31_Id, Deriv_32_Id, Deriv_33_Id, Deriv_34_Id, Deriv_35_Id, Deriv_36_Id, Deriv_37_Id, Deriv_38_Id, Deriv_39_Id, Deriv_40_Id, Mid_13_Id, Mid_14_Id, Mid_19_Id, Mid_33_Id, Mid_34_Id, Mid_39_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, Par_12_Id, Par_13_Id, Par_14_Id, Par_15_Id, Par_16_Id, Par_17_Id, Par_18_Id, Par_19_Id, Par_20_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) No derivations -- ----------------------- type No_Deriv_1 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => No_Deriv_1.D_1 > 1 and then D_2 > 2; type No_Deriv_2 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => No_Deriv_2.D_1 > 1 and then D_2 > 2; --------------------------- -- 2) Tagged derivations -- --------------------------- -- No overriding -- No discriminants -- Visible derivation 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; type Deriv_1 is new Par_1 with private; -- DIC calls: A (Par_1, Par_1.D_1, Par_1.D_2) -- No overriding -- Unknown discriminants -- Hidden derivation 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; type Deriv_2 (<>) is tagged private; -- DIC calls: B (Par_2, Par_2.D_1, Par_2.D_2) -- No overriding -- Renaming -- Visible derivation 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; type Deriv_3 (D_2 : Integer; D_3 : Integer) is new Par_3 with private; -- D_2 renames Par_3.D_2 -- D_3 renames Par_3.D_1 -- DIC calls: C (Par_3, Deriv_3.D_3, Deriv_3.D_2) -- No overriding -- Renaming -- Hidden derivation 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; type Deriv_4 (D_1 : Integer; D_3 : Integer) is private; -- D_1 renames Par_4.D_1 -- D_3 renames Par_4.D_2 -- DIC calls: D (Par_4, Deriv_4.D_1, Deriv_4.D_3) -- No overriding -- Girder -- Visible derivation 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 constrained to 123 -- Par_5.D_2 constrained to 456 -- DIC calls: E (Par_5, 123, 456) -- No overriding -- Girder -- Hidden derivation 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 is tagged private; -- Par_6.D_1 constrained to 123 -- Par_6.D_2 constrained to 456 -- DIC calls: F (Par_6, 123, 456) -- Overriding -- No discriminants -- Visible derivation 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; type Deriv_7 is new Par_7 with private; -- DIC calls: G (Deriv_7, Par_7.D_1, Par_7.D_2) function G (Obj : Deriv_7; X : Integer; Y : Integer) return Boolean; -- Overriding -- No discriminants -- Hidden derivation type Par_8 (D_1 : Integer; D_2 : Integer) is tagged 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; type Deriv_8 (<>) is tagged private; -- DIC calls: H (Deriv_8, Par_8.D_1, Par_8.D_2); function H (Obj : Deriv_8; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming -- Visible derivation type Par_9 (D_1 : Integer; D_2 : Integer) is tagged 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; type Deriv_9 (D_2 : Integer; D_1 : Integer) is new Par_9 with private; -- D_2 renames Par_9.D_1 -- D_1 renames Par_9.D_2 -- DIC calls: I (Deriv_9, Deriv_9.D_2, Deriv_9.D_1) function I (Obj : Deriv_9; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming -- Hidden derivation type Par_10 (D_1 : Integer; D_2 : Integer) is tagged 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_1 : Integer; D_4 : Integer) is tagged private; -- D_1 renames Par_10.D_2 -- D_4 renames Par_10.D_1 -- DIC calls: J (Deriv_10, Deriv_10.D_4, Deriv_10.D_1) function J (Obj : Deriv_10; X : Integer; Y : Integer) return Boolean; -- Overriding -- Girder -- Visible derivation type Par_11 (D_1 : Integer; D_2 : Integer) is tagged 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) is new Par_11 with private; -- Par_11.D_1 constained to 123 -- Par_11.D_2 constained to 456 -- DIC calls: K (Deriv_11, 123, 456) function K (Obj : Deriv_11; X : Integer; Y : Integer) return Boolean; -- Overriding -- Girder -- Hidden derivation type Par_12 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => L (Par_12, Par_12.D_1, D_2); function L (Obj : Par_12; X : Integer; Y : Integer) return Boolean; type Deriv_12 (<>) is tagged private; -- Par_12.D_1 constrained to 123 -- Par_12.D_2 constrained to 456 -- DIC calls: L (Deriv_12, 123, 456) function L (Obj : Deriv_12; X : Integer; Y : Integer) return Boolean; ------------------------------------------ -- 3) Tagged derivations, special cases -- ------------------------------------------ -- Long chain -- Overriding -- Renaming + Girder -- Mixed derivation type Par_13 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => M (Par_13, Par_13.D_1, D_2); function M (Obj : Par_13; X : Integer; Y : Integer) return Boolean; type Mid_13 (D_3 : Integer) is new Par_13 with private; -- Par_13.D_1 constrained to 123 -- D_3 renames Par_13.D_2 -- DIC calls: M (Par_13, 123, Mid_13.D_3) type Deriv_13 (D_1 : Integer) is tagged private; -- D_1 renames Mid_13.D_3 -- DIC calls: M (Deriv_13, 123, Deriv_13.D_1) function M (Obj : Deriv_13; X : Integer; Y : Integer) return Boolean; -- Long chain -- Overriding -- Renaming -- Mixed derivation type Par_14 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => N (Par_14, Par_14.D_1, D_2); function N (Obj : Par_14; X : Integer; Y : Integer) return Boolean; type Mid_14 (<>) is tagged private; -- inherits Par_14.D_1 -- inherits Par_14.D_2 -- DIC calls: N (Mid_14, Par_14.D_1, Par_14.D_2) function N (Obj : Mid_14; X : Integer; Y : Integer) return Boolean; type Deriv_14 (D_2 : Integer; D_3 : Integer) is new Mid_14 with private; -- Deriv_14.D_2 renames Mid_14.D_2 -- Deriv_14.D_3 renames Mid_14.D_1 -- DIC calls: N (Deriv_14, Deriv_14.D_3, Deriv_14.D_2) function N (Obj : Deriv_14; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming + fewer discriminants -- Visible derivation type Par_15 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => O (Par_15, Par_15.D_1, D_2); function O (Obj : Par_15; X : Integer; Y : Integer) return Boolean; type Deriv_15 (D_3 : Integer) is new Par_15 with private; -- Deriv_15.D_3 constrains Par_15.D_1 and Par_15.D_2 -- DIC calls: O (Deriv_15, Deriv_15.D_3, Deriv_15.D_3) function O (Obj : Deriv_15; X : Integer; Y : Integer) return Boolean; ----------------------------- -- 4) Untagged derivations -- ----------------------------- -- Inheritance -- No discriminants type Par_16 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => P (Par_16, Par_16.D_1, D_2); function P (Obj : Par_16; X : Integer; Y : Integer) return Boolean; -- Inheritance -- Renaming type Par_17 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => Q (Par_17, Par_17.D_1, D_2); function Q (Obj : Par_17; X : Integer; Y : Integer) return Boolean; -- Inheritance -- Girder type Par_18 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => R (Par_18, Par_18.D_1, D_2); function R (Obj : Par_18; X : Integer; Y : Integer) return Boolean; -------------------------------------------- -- 5) Untagged derivations, special cases -- -------------------------------------------- -- Long chain -- Inheritance -- Renaming + Girder type Par_19 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => S (Par_19, Par_19.D_1, D_2); function S (Obj : Par_19; X : Integer; Y : Integer) return Boolean; -- Inheritance -- Renaming + fewer discriminants type Par_20 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => T (Par_20, Par_20.D_1, D_2); function T (Obj : Par_20; X : Integer; Y : Integer) return Boolean; procedure Test_Deriv_2; procedure Test_Deriv_6; procedure Test_Deriv_8; procedure Test_Deriv_12; procedure Test_Deriv_16; procedure Test_Deriv_17; procedure Test_Deriv_18; procedure Test_Deriv_19; procedure Test_Deriv_20; procedure Test_DN_Deriv_14; procedure Test_Mid_14; procedure Test_Mid_19; private type No_Deriv_1 (D_1 : Integer; D_2 : Integer) is null record; type No_Deriv_2 (D_1 : Integer; D_2 : Integer) is tagged null record; type Par_1 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_1 is new Par_1 with null record; type Par_2 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_2 is new Par_2 with null record; type Par_3 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_3 (D_2 : Integer; D_3 : Integer) is new Par_3 (D_1 => D_3, D_2 => D_2) with null record; type Par_4 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_4 (D_1 : Integer; D_3 : Integer) is new Par_4 (D_1 => D_1, D_2 => D_3) with null record; type Par_5 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_5 (D_3 : Integer; D_4 : Integer) is new Par_5 (D_1 => 123, D_2 => 456) with null record; type Par_6 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_6 is new Par_6 (D_1 => 123, D_2 => 456) with null record; type Par_7 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_7 is new Par_7 with null record; type Par_8 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_8 is new Par_8 with null record; type Par_9 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_9 (D_2 : Integer; D_1 : Integer) is new Par_9 (D_1 => D_2, D_2 => D_1) with null record; type Par_10 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_10 (D_1 : Integer; D_4 : Integer) is new Par_10 (D_1 => D_4, D_2 => D_1) with null record; type Par_11 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_11 (D_3 : Integer) is new Par_11 (D_1 => 123, D_2 => 456) with null record; type Par_12 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_12 is new Par_12 (D_1 => 123, D_2 => 456) with null record; type Par_13 (D_1 : Integer; D_2 : Integer) is tagged null record; type Mid_13 (D_3 : Integer) is new Par_13 (D_1 => 123, D_2 => D_3) with null record; type Deriv_13 (D_1 : Integer) is new Mid_13 (D_3 => D_1) with null record; type Par_14 (D_1 : Integer; D_2 : Integer) is tagged null record; type Mid_14 is new Par_14 with null record; type Deriv_14 (D_2 : Integer; D_3 : Integer) is new Mid_14 (D_1 => D_3, D_2 => D_2) with null record; type Par_15 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_15 (D_3 : Integer) is new Par_15 (D_1 => D_3, D_2 => D_3) with null record; ----------------------------- -- 4) Untagged derivations -- ----------------------------- -- Inheritance -- No discriminants type Par_16 (D_1 : Integer; D_2 : Integer) is null record; type Deriv_16 is new Par_16; -- DIC calls: P (Par_16, Par_16.D_1, Par_16.D_2) -- Inheritance -- Renaming type Par_17 (D_1 : Integer; D_2 : Integer) is null record; type Deriv_17 (D_2 : Integer; D_3 : Integer) is new Par_17 (D_1 => D_3, D_2 => D_2); -- Deriv_17.D_2 renames Par_17.D_2 -- Deriv_17.D_3 renames Par_17.D_1 -- DIC calls: Q (Par_17, Deriv_17.D_3, Deriv_17.D_2) -- Inheritance -- Girder type Par_18 (D_1 : Integer; D_2 : Integer) is null record; type Deriv_18 is new Par_18 (D_1 => 123, D_2 => 456); -- Par_18.D_1 constrained by 123 -- Par_18.D_2 constrained by 456 -- DIC calls: R (Par_18, 123, 456) -------------------------------------------- -- 5) Untagged derivations, special cases -- -------------------------------------------- -- Long chain -- Inheritance -- Renaming + Girder type Par_19 (D_1 : Integer; D_2 : Integer) is null record; type Mid_19 (D_3 : Integer) is new Par_19 (D_1 => 123, D_2 => D_3); -- Par_19.D_1 constrained by 123 -- Mid_19.D_3 renames Par_19.D_2 -- DIC calls: R (Par_19, 123, Mid_19.D_3) type Deriv_19 (D_1 : Integer) is new Mid_19 (D_1); -- Deriv_19.D_1 renames Mid_19.D_3 -- DIC calls: R (Par_19, 123, Deriv_19.D_1) -- Inheritance -- Renaming + fewer discriminants type Par_20 (D_1 : Integer; D_2 : Integer) is null record; type Deriv_20 (D_3 : Integer) is new Par_20 (D_1 => D_3, D_2 => D_3); -- Deriv_20.D_3 constrains Par_20.D_1 and Par_20.D_2 -- DIC calls: T (Par_20, Deriv_20.D_3, Deriv_20.D_3) end DIC_Pack1; -- dic_pack1.adb with DIC_Generic; 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 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 E (Obj : Par_5; X : Integer; Y : Integer) return Boolean is begin Mark (Par_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 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 H (Obj : Deriv_8; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_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 I (Obj : Deriv_9; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_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 J (Obj : Deriv_10; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_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; function K (Obj : Deriv_11; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_11_Id, X, Y); return True; end K; function L (Obj : Par_12; X : Integer; Y : Integer) return Boolean is begin Mark (Par_12_Id, X, Y); return True; end L; function L (Obj : Deriv_12; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_12_Id, X, Y); return True; end L; function M (Obj : Par_13; X : Integer; Y : Integer) return Boolean is begin Mark (Par_13_Id, X, Y); return True; end M; function M (Obj : Deriv_13; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_13_Id, X, Y); return True; end M; function N (Obj : Par_14; X : Integer; Y : Integer) return Boolean is begin Mark (Par_14_Id, X, Y); return True; end N; function N (Obj : Mid_14; X : Integer; Y : Integer) return Boolean is begin Mark (Mid_14_Id, X, Y); return True; end N; function N (Obj : Deriv_14; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_14_Id, X, Y); return True; end N; function O (Obj : Par_15; X : Integer; Y : Integer) return Boolean is begin Mark (Par_15_Id, X, Y); return True; end O; function O (Obj : Deriv_15; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_15_Id, X, Y); return True; end O; function P (Obj : Par_16; X : Integer; Y : Integer) return Boolean is begin Mark (Par_16_Id, X, Y); return True; end P; function Q (Obj : Par_17; X : Integer; Y : Integer) return Boolean is begin Mark (Par_17_Id, X, Y); return True; end Q; function R (Obj : Par_18; X : Integer; Y : Integer) return Boolean is begin Mark (Par_18_Id, X, Y); return True; end R; function S (Obj : Par_19; X : Integer; Y : Integer) return Boolean is begin Mark (Par_19_Id, X, Y); return True; end S; function T (Obj : Par_20; X : Integer; Y : Integer) return Boolean is begin Mark (Par_20_Id, X, Y); return True; end T; procedure Test_Deriv_2 is Obj : Deriv_2 (2, 22); begin null; end Test_Deriv_2; procedure Test_Deriv_6 is Obj : Deriv_6; begin null; end Test_Deriv_6; procedure Test_Deriv_8 is Obj : Deriv_8 (8, 88); begin null; end Test_Deriv_8; procedure Test_Deriv_12 is Obj : Deriv_12; begin null; end Test_Deriv_12; procedure Test_Deriv_16 is Obj : Deriv_16 (16, 1616); begin null; end Test_Deriv_16; procedure Test_Deriv_17 is Obj : Deriv_17 (17, 1717); begin null; end Test_Deriv_17; procedure Test_Deriv_18 is Obj : Deriv_18; begin null; end Test_Deriv_18; procedure Test_Deriv_19 is Obj : Deriv_19 (1919); begin null; end Test_Deriv_19; procedure Test_Deriv_20 is Obj : Deriv_20 (20); begin null; end Test_Deriv_20; procedure Test_DN_Deriv_14 is procedure Gen_14 is new DIC_Generic (Deriv_14); begin Gen_14 (14, 1414); end Test_DN_Deriv_14; procedure Test_Mid_14 is Obj : Mid_14 (14, 1414); begin null; end Test_Mid_14; procedure Test_Mid_19 is Obj : Mid_19 (19); begin null; end Test_Mid_19; end DIC_Pack1; -- dic_generic.ads generic type Formal (FD_1 : Integer; FD_2 : Integer) is private; procedure DIC_Generic (X : Integer; Y : Integer); -- dic_generic.adb procedure DIC_Generic (X : Integer; Y : Integer) is Obj : Formal (X, Y); pragma Warnings (Off, Obj); begin null; end DIC_Generic; -- dic_pack2.ads with DIC_Pack1; use DIC_Pack1; package DIC_Pack2 is --------------------------- -- 1) Tagged derivations -- --------------------------- -- No overriding -- No discriminants -- Visible derivation type Deriv_21 is new Par_1 with private; -- DIC calls A (Par_1, Par_1.D_1, Par_1.D_2) -- No overriding -- Unknown discriminants -- Hidden derivation type Deriv_22 (<>) is tagged private; -- DIC calls: B (Par_2, Par_2.D_1, Par_2.D_2) -- No overriding -- Renaming -- Visible derivation type Deriv_23 (D_2 : Integer; D_3 : Integer) is new Par_3 with private; -- D_2 renames Par_3.D_2 -- D_3 renames Par_3.D_1 -- DIC calls: C (Par_3, Deriv_3.D_3, Deriv_3.D_2) -- No overriding -- Renaming -- Hidden derivation type Deriv_24 (D_1 : Integer; D_3 : Integer) is private; -- D_1 renames Par_4.D_1 -- D_3 renames Par_4.D_2 -- DIC calls: D (Par_4, Deriv_4.D_1, Deriv_4.D_3) -- No overriding -- Girder -- Visible derivation type Deriv_25 (D_3 : Integer; D_4 : Integer) is new Par_5 with private; -- Par_5.D_1 constrained to 123 -- Par_5.D_2 constrained to 456 -- DIC calls: E (Par_5, 123, 456) -- No overriding -- Girder -- Hidden derivation type Deriv_26 is tagged private; -- Par_6.D_1 constrained to 123 -- Par_6.D_2 constrained to 456 -- DIC calls: F (Par_6, 123, 456) -- Overriding -- No discriminants -- Visible derivation type Deriv_27 is new Par_7 with private; -- DIC calls: G (Deriv_27, Par_7.D_1, Par_7.D_2) function G (Obj : Deriv_27; X : Integer; Y : Integer) return Boolean; -- Overriding -- No discriminants -- Hidden derivation type Deriv_28 (<>) is tagged private; -- DIC calls: H (Deriv_28, Par_8.D_1, Par_8.D_2); function H (Obj : Deriv_28; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming -- Visible derivation type Deriv_29 (D_2 : Integer; D_1 : Integer) is new Par_9 with private; -- D_2 renames Par_9.D_1 -- D_1 renames Par_9.D_2 -- DIC calls: I (Deriv_29, Deriv_29.D_2, Deriv_29.D_1) function I (Obj : Deriv_29; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming -- Hidden derivation type Deriv_30 (D_1 : Integer; D_4 : Integer) is tagged private; -- D_1 renames Par_10.D_2 -- D_4 renames Par_10.D_1 -- DIC calls: J (Deriv_30, Deriv_30.D_4, Deriv_30.D_1) function J (Obj : Deriv_30; X : Integer; Y : Integer) return Boolean; -- Overriding -- Girder -- Visible derivation type Deriv_31 (D_3 : Integer) is new Par_11 with private; -- Par_11.D_1 constained to 123 -- Par_11.D_2 constained to 456 -- DIC calls: K (Deriv_31, 123, 456) function K (Obj : Deriv_31; X : Integer; Y : Integer) return Boolean; -- Overriding -- Girder -- Hidden derivation type Deriv_32 (<>) is tagged private; -- Par_12.D_1 constrained to 123 -- Par_12.D_2 constrained to 456 -- DIC calls: L (Deriv_32, 123, 456) function L (Obj : Deriv_32; X : Integer; Y : Integer) return Boolean; ------------------------------------------ -- 2) Tagged derivations, special cases -- ------------------------------------------ -- Long chain -- Renaming + Girder -- Mixed derivation type Mid_33 (D_3 : Integer) is new Par_13 with private; -- Par_13.D_1 constrained to 123 -- D_3 renames Par_13.D_2 -- DIC calls: M (Par_13, 123, Mid_33.D_3) type Deriv_33 (D_1 : Integer) is tagged private; -- D_1 renames Mid_33.D_3 -- DIC calls: M (Deriv_33, 123, Deriv_33.D_1) function M (Obj : Deriv_33; X : Integer; Y : Integer) return Boolean; -- Long chain -- Overriding -- Renaming -- Hidden derivation type Mid_34 (<>) is tagged private; -- inherits Par_14.D_1 -- inherits Par_14.D_2 -- DIC calls: N (Mid_34, Par_14.D_1, Par_14.D_2) function N (Obj : Mid_34; X : Integer; Y : Integer) return Boolean; type Deriv_34 (D_2 : Integer; D_3 : Integer) is tagged private; -- Deriv_34.D_2 renames Mid_34.D_2 -- Deriv_34.D_3 renames Mid_34.D_1 -- DIC calls: N (Deriv_34, Deriv_34.D_3, Deriv_34.D_2) function N (Obj : Deriv_34; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming + fewer discriminants -- Visible derivation type Deriv_35 (D_3 : Integer) is new Par_15 with private; -- Deriv_35.D_3 constrains Par_15.D_1 and Par_15.D_2 -- DIC calls: O (Deriv_35, Deriv_35.D_3, Deriv_35.D_3) function O (Obj : Deriv_35; X : Integer; Y : Integer) return Boolean; ----------------------------- -- 3) Untagged derivations -- ----------------------------- -- Inheritance -- No discriminants type Deriv_36 is new Par_16; -- DIC calls: P (Par_16, Par_16.D_1, Par_16.D_2) -- Inheritance -- Renaming type Deriv_37 (D_2 : Integer; D_3 : Integer) is new Par_17 (D_1 => D_3, D_2 => D_2); -- Deriv_37.D_2 renames Par_17.D_2 -- Deriv_37.D_3 renames Par_17.D_1 -- DIC calls: Q (Par_17, Deriv_37.D_3, Deriv_37.D_2) -- Inheritance -- Girder type Deriv_38 is new Par_18 (D_1 => 123, D_2 => 456); -- Par_38.D_1 constrained by 123 -- Par_38.D_2 constrained by 456 -- DIC calls: R (Par_38, 123, 456) -------------------------------------------- -- 4) Untagged derivations, special cases -- -------------------------------------------- -- Long chain -- Inheritance -- Renaming + Girder type Mid_39 (D_3 : Integer) is new Par_19 (D_1 => 123, D_2 => D_3); -- Par_19.D_1 constrained by 123 -- Mid_39.D_3 renames Par_19.D_2 -- DIC calls: R (Par_19, 123, Mid_39.D_3) type Deriv_39 (D_1 : Integer) is new Mid_39 (D_1); -- Deriv_39.D_1 renames Mid_39.D_3 -- DIC calls: R (Par_19, 123, Deriv_39.D_1) -- Inheritance -- Renaming + fewer discriminants type Deriv_40 (D_3 : Integer) is new Par_20 (D_1 => D_3, D_2 => D_3); -- Deriv_40.D_3 constrains Par_20.D_1 and Par_20.D_2 -- DIC calls: T (Par_20, Deriv_40.D_3, Deriv_40.D_3) procedure Test_Deriv_22; procedure Test_Deriv_28; procedure Test_Deriv_32; procedure Test_Mid_34; private type Deriv_21 is new Par_1 with null record; type Deriv_22 is new Par_2 with null record; type Deriv_23 (D_2 : Integer; D_3 : Integer) is new Par_3 (D_1 => D_3, D_2 => D_2) with null record; type Deriv_24 (D_1 : Integer; D_3 : Integer) is new Par_4 (D_1 => D_1, D_2 => D_3) with null record; type Deriv_25 (D_3 : Integer; D_4 : Integer) is new Par_5 (D_1 => 123, D_2 => 456) with null record; type Deriv_26 is new Par_6 (D_1 => 123, D_2 => 456) with null record; type Deriv_27 is new Par_7 with null record; type Deriv_28 is new Par_8 with null record; type Deriv_29 (D_2 : Integer; D_1 : Integer) is new Par_9 (D_1 => D_2, D_2 => D_1) with null record; type Deriv_30 (D_1 : Integer; D_4 : Integer) is new Par_10 (D_1 => D_4, D_2 => D_1) with null record; type Deriv_31 (D_3 : Integer) is new Par_11 (D_1 => 123, D_2 => 456) with null record; type Deriv_32 is new Par_12 (D_1 => 123, D_2 => 456) with null record; type Mid_33 (D_3 : Integer) is new Par_13 (D_1 => 123, D_2 => D_3) with null record; type Deriv_33 (D_1 : Integer) is new Mid_33 (D_3 => D_1) with null record; type Mid_34 is new Par_14 with null record; type Deriv_34 (D_2 : Integer; D_3 : Integer) is new Mid_34 (D_1 => D_3, D_2 => D_2) with null record; type Deriv_35 (D_3 : Integer) is new Par_15 (D_1 => D_3, D_2 => D_3) with null record; end DIC_Pack2; -- dic_pack2.adb with Tester; use Tester; package body DIC_Pack2 is function G (Obj : Deriv_27; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_27_Id, X, Y); return True; end G; function H (Obj : Deriv_28; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_28_Id, X, Y); return True; end H; function I (Obj : Deriv_29; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_29_Id, X, Y); return True; end I; function J (Obj : Deriv_30; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_30_Id, X, Y); return True; end J; function K (Obj : Deriv_31; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_31_Id, X, Y); return True; end K; function L (Obj : Deriv_32; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_32_Id, X, Y); return True; end L; function M (Obj : Deriv_33; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_33_Id, X, Y); return True; end M; function N (Obj : Mid_34; X : Integer; Y : Integer) return Boolean is begin Mark (Mid_34_Id, X, Y); return True; end N; function N (Obj : Deriv_34; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_34_Id, X, Y); return True; end N; function O (Obj : Deriv_35; X : Integer; Y : Integer) return Boolean is begin Mark (Deriv_35_Id, X, Y); return True; end O; procedure Test_Deriv_22 is Obj : Deriv_22 (22, 2222); begin null; end Test_Deriv_22; procedure Test_Deriv_28 is Obj : Deriv_28 (28, 2828); begin null; end Test_Deriv_28; procedure Test_Deriv_32 is Obj : Deriv_32; begin null; end Test_Deriv_32; procedure Test_Mid_34 is Obj : Mid_34 (34, 3434); begin null; end Test_Mid_34; 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; declare Obj : Deriv_1 (1, 11); begin Test_Result ("Deriv_1", (Par_1_Id => (1, 11), others => No_Result)); end; Reset_Results; Test_Deriv_2; Test_Result ("Deriv_2", (Par_2_Id => (2, 22), others => No_Result)); Reset_Results; declare Obj : Deriv_3 (3, 33); begin Test_Result ("Deriv_3", (Par_3_Id => (33, 3), others => No_Result)); end; Reset_Results; declare Obj : Deriv_4 (4, 44); begin Test_Result ("Deriv_4", (Par_4_Id => (4, 44), others => No_Result)); end; Reset_Results; declare Obj : Deriv_5 (5, 55); begin Test_Result ("Deriv_5", (Par_5_Id => (123, 456), others => No_Result)); end; Reset_Results; Test_Deriv_6; Test_Result ("Deriv_6", (Par_6_Id => (123, 456), others => No_Result)); Reset_Results; declare Obj : Deriv_7 (7, 77); begin Test_Result ("Deriv_7", (Deriv_7_Id => (7, 77), others => No_Result)); end; Reset_Results; Test_Deriv_8; Test_Result ("Deriv_8", (Deriv_8_Id => (8, 88), others => No_Result)); Reset_Results; declare Obj : Deriv_9 (9, 99); begin Test_Result ("Deriv_9", (Deriv_9_Id => (9, 99), others => No_Result)); end; Reset_Results; declare Obj : Deriv_10 (10, 1010); begin Test_Result ("Deriv_10", (Deriv_10_Id => (1010, 10), others => No_Result)); end; Reset_Results; declare Obj : Deriv_11 (11); begin Test_Result ("Deriv_11", (Deriv_11_Id => (123, 456), others => No_Result)); end; Reset_Results; Test_Deriv_12; Test_Result ("Deriv_12", (Deriv_12_Id => (123, 456), others => No_Result)); Reset_Results; declare Obj : Mid_13 (13); begin Test_Result ("Mid_13", (Par_13_Id => (123, 13), others => No_Result)); end; Reset_Results; declare Obj : Deriv_13 (1313); begin Test_Result ("Deriv_13", (Deriv_13_Id => (123, 1313), others => No_Result)); end; Reset_Results; Test_Mid_14; Test_Result ("Mid_14", (Mid_14_Id => (14, 1414), others => No_Result)); Reset_Results; declare Obj : Deriv_14 (14, 1414); begin Test_Result ("Deriv_14", (Deriv_14_Id => (1414, 14), others => No_Result)); end; Reset_Results; Test_DN_Deriv_14; Test_Result ("Deriv_14_DN", (Deriv_14_Id => (1414, 14), others => No_Result)); Reset_Results; declare Obj : Deriv_15 (15); begin Test_Result ("Deriv_15", (Deriv_15_Id => (15, 15), others => No_Result)); end; Reset_Results; Test_Deriv_16; Test_Result ("Deriv_16", (Par_16_Id => (16, 1616), others => No_Result)); Reset_Results; Test_Deriv_17; Test_Result ("Deriv_17", (Par_17_Id => (1717, 17), others => No_Result)); Reset_Results; Test_Deriv_18; Test_Result ("Deriv_18", (Par_18_Id => (123, 456), others => No_Result)); Reset_Results; Test_Mid_19; Test_Result ("Mid_19", (Par_19_Id => (123, 19), others => No_Result)); Reset_Results; Test_Deriv_19; Test_Result ("Deriv_19", (Par_19_Id => (123, 1919), others => No_Result)); Reset_Results; Test_Deriv_20; Test_Result ("Deriv_20", (Par_20_Id => (20, 20), others => No_Result)); Reset_Results; declare Obj : Deriv_21 (21, 2121); begin Test_Result ("Deriv_21", (Par_1_Id => (21, 2121), others => No_Result)); end; Reset_Results; Test_Deriv_22; Test_Result ("Deriv_22", (Par_2_Id => (22, 2222), others => No_Result)); Reset_Results; declare Obj : Deriv_23 (23, 2323); begin Test_Result ("Deriv_23", (Par_3_Id => (2323, 23), others => No_Result)); end; Reset_Results; declare Obj : Deriv_24 (24, 2424); begin Test_Result ("Deriv_24", (Par_4_Id => (24, 2424), others => No_Result)); end; Reset_Results; declare Obj : Deriv_25 (25, 2525); begin Test_Result ("Deriv_25", (Par_5_Id => (123, 456), others => No_Result)); end; Reset_Results; declare Obj : Deriv_26; begin Test_Result ("Deriv_26", (Par_6_Id => (123, 456), others => No_Result)); end; Reset_Results; declare Obj : Deriv_27 (27, 2727); begin Test_Result ("Deriv_27", (Deriv_27_Id => (27, 2727), others => No_Result)); end; Reset_Results; Test_Deriv_28; Test_Result ("Deriv_28", (Deriv_28_Id => (28, 2828), others => No_Result)); Reset_Results; declare Obj : Deriv_29 (29, 2929); begin Test_Result ("Deriv_29", (Deriv_29_Id => (29, 2929), others => No_Result)); end; Reset_Results; declare Obj : Deriv_30 (30, 3030); begin Test_Result ("Deriv_30", (Deriv_30_Id => (3030, 30), others => No_Result)); end; Reset_Results; declare Obj : Deriv_31 (31); begin Test_Result ("Deriv_31", (Deriv_31_Id => (123, 456), others => No_Result)); end; Reset_Results; Test_Deriv_32; Test_Result ("Deriv_32", (Deriv_32_Id => (123, 456), others => No_Result)); Reset_Results; declare Obj : Mid_33 (33); begin Test_Result ("Mid_33", (Par_13_Id => (123, 33), others => No_Result)); end; Reset_Results; declare Obj : Deriv_33 (3333); begin Test_Result ("Deriv_33", (Deriv_33_Id => (123, 3333), others => No_Result)); end; Reset_Results; Test_Mid_34; Test_Result ("Mid_34", (Mid_34_Id => (34, 3434), others => No_Result)); Reset_Results; declare Obj : Deriv_34 (34, 3434); begin Test_Result ("Deriv_34", (Deriv_34_Id => (3434, 34), others => No_Result)); end; Reset_Results; declare Obj : Deriv_35 (35); begin Test_Result ("Deriv_35", (Deriv_35_Id => (35, 35), others => No_Result)); end; Reset_Results; declare Obj : Deriv_36 (36, 3636); begin Test_Result ("Deriv_36", (Par_16_Id => (36, 3636), others => No_Result)); end; Reset_Results; declare Obj : Deriv_37 (37, 3737); begin Test_Result ("Deriv_37", (Par_17_Id => (3737, 37), others => No_Result)); end; Reset_Results; declare Obj : Deriv_38; begin Test_Result ("Deriv_38", (Par_18_Id => (123, 456), others => No_Result)); end; Reset_Results; declare Obj : Deriv_39 (39); begin Test_Result ("Deriv_39", (Par_19_Id => (123, 39), others => No_Result)); end; Reset_Results; declare Obj : Deriv_40 (40); begin Test_Result ("Deriv_40", (Par_20_Id => (40, 40), others => No_Result)); end; end DIC_Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnata dic_main.adb $ ./dic_main Deriv_1: OK Deriv_2: OK Deriv_3: OK Deriv_4: OK Deriv_5: OK Deriv_6: OK Deriv_7: OK Deriv_8: OK Deriv_9: OK Deriv_10: OK Deriv_11: OK Deriv_12: OK Mid_13: OK Deriv_13: OK Mid_14: OK Deriv_14: OK Deriv_14_DN: OK Deriv_15: OK Deriv_16: OK Deriv_17: OK Deriv_18: OK Mid_19: OK Deriv_19: OK Deriv_20: OK Deriv_21: OK Deriv_22: OK Deriv_23: OK Deriv_24: OK Deriv_25: OK Deriv_26: OK Deriv_27: OK Deriv_28: OK Deriv_29: OK Deriv_30: OK Deriv_31: OK Deriv_32: OK Mid_33: OK Deriv_33: OK Mid_34: OK Deriv_34: OK Deriv_35: OK Deriv_36: OK Deriv_37: OK Deriv_38: OK Deriv_39: OK Deriv_40: OK Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-25 Hristian Kirtchev <kirtchev@adacore.com> * elists.ads, elists.adb (Prepend_Unique_Elmt): New routine. * exp_ch3.adb (Freeze_Type): Signal the DIC body is created for the purposes of freezing. * exp_util.adb Update the documentation and structure of the type map used in class-wide semantics of assertion expressions. (Add_Inherited_Tagged_DIC): There is really no need to preanalyze and resolve the triaged expression because all substitutions refer to the proper entities. Update the replacement of references. (Build_DIC_Procedure_Body): Add formal parameter For_Freeze. Add local variable Build_Body. Inherited DIC pragmas are now only processed when freezing occurs. Build a body only when one is needed. (Entity_Hash): Removed. (Map_Types): New routine. (Replace_Object_And_Primitive_References): Removed. (Replace_References): New routine. (Replace_Type_References): Moved to the library level of Exp_Util. (Type_Map_Hash): New routine. (Update_Primitives_Mapping): Update the mapping call. (Update_Primitives_Mapping_Of_Types): Removed. * exp_util.ads (Build_DIC_Procedure_Body): Add formal parameter For_Freeze and update the comment on usage. (Map_Types): New routine. (Replace_References): New routine. (Replace_Type_References): Moved to the library level of Exp_Util. (Update_Primitives_Mapping_Of_Types): Removed. * sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC properties of the private type to the full view in case the full view derives from a parent type and inherits a DIC pragma. * sem_prag.adb (Analyze_Pragma): Guard against a case where a DIC pragma is placed at the top of a declarative region.
Attachment:
difs
Description: Text document
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |