-- cy30036.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-345 and AI-399 (abstract interface types) -- -- Check task interfaces -- -- CHANGE HISTORY: -- 15 May 2005 Initial Version --! with Report; procedure cy30036 is package pack is type Iface is task interface; procedure Prim1_1 (M : in out Iface) is abstract; procedure Prim1_2 (M : in out Iface; Value : Integer) is abstract; procedure Prim2_1 (M : out Iface) is abstract; procedure Prim2_2 (M : out Iface; Value : Integer) is abstract; -- The "dummy" entry added to the protected types is used to ensure that -- the first entry of the primary dispatch table is busy. In addition, -- the entries covering interface primitives have been put in an order -- that is different from the order found in the specification of the -- implemented interface. -- This task type implements all the interface primitives by means of -- entries task type Task_T is new Iface with entry Dummy; entry Prim2_2 (Value : Integer); entry Prim2_1; entry Prim1_2 (Value : Integer); entry Prim1_1; end Task_T; -- This single task implements all the interface primitives by -- means of entries task Single_Task is new Iface with entry Dummy; entry Prim2_2 (Value : Integer); entry Prim2_1; entry Prim1_2 (Value : Integer); entry Prim1_1; end Single_Task; end pack; package body Pack is task body Task_T is begin loop select accept Dummy do Report.Failed ("Dummy"); end; or accept Prim1_1 do Report.Comment ("11"); end; or accept Prim1_2 (Value : Integer) do pragma Assert (Value = 10); Report.Comment ("12"); end; or accept Prim2_1 do Report.Comment ("21"); end; or accept Prim2_2 (Value : Integer) do pragma Assert (Value = 10); Report.Comment ("22"); end; or terminate; end select; end loop; end Task_T; task body Single_Task is begin loop select accept Dummy do Report.Failed ("Dummy"); end; or accept Prim1_1 do Report.Comment ("S-11 "); end; or accept Prim1_2 (Value : Integer) do pragma Assert (Value = 10); Report.Comment ("S-12"); end; or accept Prim2_1 do Report.Comment ("S-21"); end; or accept Prim2_2 (Value : Integer) do pragma Assert (Value = 10); Report.Comment ("S-22 "); end; or terminate; end select; end loop; end Single_Task; end Pack; use Pack; procedure Dispatch_Calls_1 (X : out Iface'Class) is begin Report.Comment ("Dispatch calls (out mode): "); X.Prim1_1; X.Prim1_2 (10); X.Prim2_1; X.Prim2_2 (10); end Dispatch_Calls_1; procedure Dispatch_Calls (X : in out Iface'Class) is begin Report.Comment ("Dispatch calls (in-out mode): "); X.Prim1_1; X.Prim1_2 (10); X.Prim2_1; X.Prim2_2 (10); end Dispatch_Calls; procedure Dispatch_Calls (X : access Iface'Class) is begin Report.Comment ("Dispatch calls (access mode)"); X.Prim1_1; X.Prim1_2 (10); X.Prim2_1; X.Prim2_2 (10); end Dispatch_Calls; O : aliased Task_T; begin Report.Test ("CY30036", "Interface types (AI-345 and AI-399)"); Dispatch_Calls_1 (O); Dispatch_Calls_1 (Single_Task); Dispatch_Calls (O); Dispatch_Calls (Single_Task); Dispatch_Calls (O'Access); -- Note: Dispatch_Calls (Single_Task'Access) is illegal because -- single_task_declaration is not aliased (see 3.10(9/2)) Report.Result; end cy30036;