-- cy30016.a -- -- Grant of Unlimited Rights -- -- AdaCore holds unlimited rights in the software and documentation -- contained herein. Unlimited rights are the same as those granted -- by the U.S. Government for older parts of the Ada Conformity -- Assessment Test Suite, and are defined in DFAR 252.227-7013(a)(19). -- By making this public release, AdaCore intends to confer upon all -- recipients unlimited rights equal to those held by the Ada Conformity -- Assessment Authority. These rights include rights to use, duplicate, -- release or disclose the released technical data and computer software -- in whole or in part, in any manner and for any purpose whatsoever, -- and to have or permit others to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. ADACORE MAKES NO EXPRESS OR IMPLIED WARRANTY AS -- TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE SOFTWARE, -- DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE OR -- DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. -- -------------------------------------------------------------------------- --* -- COPYRIGHT: -- AdaCore -- -- AUTHOR: -- Javier Miranda -- -- OBJECTIVE: -- Check AI-251 (abstract interfaces with discriminants). -- -- CHANGE HISTORY: -- 29 July 2004 Initial Version --! with Report; use Report; procedure CY30016 is Debug : Boolean := False; package Pkg1 is type I1 is interface; procedure P (A : in I1; R : out Natural) is abstract; function F (X : in I1) return Natural is abstract; type I2 is interface; procedure Q (B : I2; R : out Natural) is abstract; -- Case 1: Discriminant in a root type implementing -- an interface type T1 (D : Integer) is new I1 with record Buffer : String (1 .. D) := (others => ' '); Data : Integer := 2005; end record; procedure P (X : T1; R : out Natural); function F (X : T1) return Natural; -- Case 2: Discriminant in the derived type implementing -- an interface type T2 is tagged null record; type DT2 (D : Integer) is new T2 and I1 with record Buffer : String (1 .. D) := (others => ' '); Data : Integer := 2005; end record; procedure P (X : DT2; R : out Natural); function F (X : DT2) return Natural; -- Case 3: Discriminant in the root type, and the derived -- type implements an interface type T3 (D : Integer) is tagged record Buffer : String (1 .. D) := (others => ' '); Data : Integer := 2005; end record; type DT31 is new T3 and I1 with record More_Data : Integer := 2006; end record; procedure P (X : DT31; R : out Natural); function F (X : DT31) return Natural; -- Case 4: Similar to case 3 but implementing several -- interfaces type DT32 is new T3 and I1 and I2 with record More_Data : Integer := 2006; end record; procedure Q (X : DT32; R : out Natural); procedure P (X : DT32; R : out Natural); function F (X : DT32) return Natural; -- Case 5: Similar to case 4 but the derived type -- inherits the primitives that cover the interface type T4 (D : Integer) is tagged record Buffer : String (1 .. D) := (others => ' '); Data : Integer := 2005; end record; procedure P (X : T4; R : out Natural); function F (X : T4) return Natural; procedure Q (X : T4; R : out Natural); type DT4 is new T4 and I1 and I2 with record More_Data : Integer := 2006; end record; end Pkg1; package body Pkg1 is procedure P (X : T1; R : out Natural) is begin if X.Data /= 2005 then raise Program_Error; end if; R := 10; end P; function F (X : T1) return Natural is begin if X.Data /= 2005 then raise Program_Error; end if; return 11; end F; -- --- procedure P (X : DT2; R : out Natural) is begin if X.Data /= 2005 then raise Program_Error; end if; R := 20; end P; function F (X : DT2) return Natural is begin if X.Data /= 2005 then raise Program_Error; end if; return 21; end F; --- procedure P (X : DT31; R : out Natural) is begin if X.Data /= 2005 or else X.More_Data /= 2006 then raise Program_Error; end if; R := 30; end P; function F (X : DT31) return Natural is begin if X.Data /= 2005 or else X.More_Data /= 2006 then raise Program_Error; end if; return 31; end F; --- procedure P (X : DT32; R : out Natural) is begin if X.Data /= 2005 or else X.More_Data /= 2006 then raise Program_Error; end if; R := 40; end P; function F (X : DT32) return Natural is begin if X.Data /= 2005 or else X.More_Data /= 2006 then raise Program_Error; end if; return 41; end F; procedure Q (X : DT32; R : out Natural) is begin if X.Data /= 2005 or else X.More_Data /= 2006 then raise Program_Error; end if; R := 42; end Q; --- procedure P (X : T4; R : out Natural) is begin if X.Data /= 2005 then raise Program_Error; end if; R := 50; end P; function F (X : T4) return Natural is begin if X.Data /= 2005 then raise Program_Error; end if; return 51; end F; procedure Q (X : T4; R : out Natural) is begin if X.Data /= 2005 then raise Program_Error; end if; R := 52; end Q; end Pkg1; use Pkg1; procedure I1W_P_Test (IW : in I1'Class; R : out Natural) is begin P (IW, R); end I1W_P_Test; function I1W_F_Test (IW : in I1'Class) return Natural is begin return F (IW); end I1W_F_Test; procedure I2W_Q_Test (IW : in I2'Class; R : out Natural) is begin Q (IW, R); end I2W_Q_Test; procedure Display_Msg (S : String) is begin if Debug then Report.Comment (S); end if; end Display_Msg; O_T1 : T1 (D => 50); O_DT2 : DT2 (D => 75); O_DT31 : DT31 (D => 100); O_DT32 : DT32 (D => 150); O_DT4 : DT4 (D => 200); R : Natural; begin Report.Test ("CY30016", "Abstract Interfaces and Discriminants (AI-251)"); --- Display_Msg ("Test 1"); I1W_P_Test (O_T1, R); if R /= 10 then Report.Failed ("test 1 failed"); end if; Display_Msg ("Test 2"); if I1W_F_Test (O_T1) /= 11 then Report.Failed ("test 2 failed"); end if; --- Display_Msg ("Test 3"); I1W_P_Test (O_DT2, R); if R /= 20 then Report.Failed ("test 2 failed"); end if; Display_Msg ("Test 4"); if I1W_F_Test (O_DT2) /= 21 then Report.Failed ("test 2 failed"); end if; --- Display_Msg ("Test 5"); I1W_P_Test (O_DT31, R); if R /= 30 then Report.Failed ("test 5 failed"); end if; Display_Msg ("Test 6"); if I1W_F_Test (O_DT31) /= 31 then Report.Failed ("test 6 failed"); end if; --- Display_Msg ("Test 7"); I1W_P_Test (O_DT32, R); if R /= 40 then Report.Failed ("test 7 failed"); end if; Display_Msg ("Test 8"); if I1W_F_Test (O_DT32) /= 41 then Report.Failed ("test 8 failed"); end if; Display_Msg ("Test 9"); I2W_Q_Test (O_DT32, R); if R /= 42 then Report.Failed ("test 9 failed"); end if; --- Display_Msg ("Test 10"); I1W_P_Test (O_DT4, R); if R /= 50 then Report.Failed ("test 10 failed"); end if; Display_Msg ("Test 11"); if I1W_F_Test (O_DT4) /= 51 then Report.Failed ("test 11 failed"); end if; I2W_Q_Test (O_DT4, R); if R /= 52 then Report.Failed ("test 12 failed"); end if; --- Report.Result; end CY30016;