-- cy30041.ada -- -- 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 interface types -- -- CHANGE HISTORY: -- 25 JUL 2005 Initial Version --! with Report; with Ada.Text_IO; use Ada.Text_IO; procedure CY30041 is package CY30041P is type Iface_1 is interface; procedure Prim_1 (Obj : in Iface_1) is abstract; type Iface_2 is interface; procedure Prim_2 (Obj : in Iface_2) is abstract; type Origin is tagged null record; type A is new Origin and Iface_1 with record A_Value : Integer := 1010; end record; overriding procedure Prim_1 (This : in A); type B is new A and Iface_2 with record B_Value : Integer := 2020; end record; overriding procedure Prim_2 (This : in B); type C is new B with record C_Value : Integer := 3030; end record; overriding procedure Prim_2 (This : in C); end CY30041P; package body CY30041P is procedure Prim_1 (This : in A) is begin if This.A_Value /= 1010 then Report.Failed ("wrong value in A (1)"); end if; end Prim_1; procedure Prim_2 (This : in B) is begin if This.A_Value /= 1010 then Report.Failed ("wrong value in B (1)"); end if; if This.B_Value /= 2020 then Report.Failed ("wrong value in B (2)"); end if; end Prim_2; procedure Prim_2 (This : in C) is begin if This.A_Value /= 1010 then Report.Failed ("wrong value in C (1)"); end if; if This.B_Value /= 2020 then Report.Failed ("wrong value in C (2)"); end if; if This.C_Value /= 3030 then Report.Failed ("wrong value in C (2)"); end if; end Prim_2; end CY30041P; use CY30041P; procedure A_Dispatch (Obj : A'Class) is begin Prim_1 (Obj); end A_Dispatch; procedure B_Dispatch (Obj : B'Class) is begin Prim_1 (Obj); Prim_2 (Obj); end B_Dispatch; procedure I1_Dispatch (Obj : Iface_1'Class) is begin Prim_1 (Obj); end I1_Dispatch; procedure I2_Dispatch (Obj : Iface_2'Class) is begin Prim_2 (Obj); end I2_Dispatch; A_Obj : A; B_Obj : B; C_Obj : C; begin Report.Test ("CY30041", "Abstract Interface Types (AI-251)"); Report.Comment ("1. Test direct calls (object.operation notation)"); A_Obj.Prim_1; B_Obj.Prim_1; B_Obj.Prim_2; C_Obj.Prim_1; C_Obj.Prim_2; Report.Comment ("2. Dispatch calls through class A"); A_Dispatch (A_Obj); A_Dispatch (B_Obj); A_Dispatch (C_Obj); Report.Comment ("3. Dispatch calls through class B"); B_Dispatch (B_Obj); B_Dispatch (C_Obj); Report.Comment ("4. Dispatch calls through Iface_1"); I1_Dispatch (A_Obj); I1_Dispatch (B_Obj); I1_Dispatch (C_Obj); Report.Comment ("5. Dispatch calls through Iface_2"); I2_Dispatch (B_Obj); I2_Dispatch (C_Obj); Report.Result; end CY30041;