-- cy30032.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: -- Hristian Kirtchev -- -- OBJECTIVE: -- Check AI-345 (protected interfaces and parameter modes) -- -- CHANGE HISTORY: -- 11 April 2005 Initial Version --! with Implementations; use Implementations; with Ifaces; use Ifaces; with Report; use Report; procedure CY30032 is ------------------------------ -- Dispatching Procedures -- ------------------------------ procedure Call_Test_PI1_1 (A : in out PI1'Class; I : out Integer); procedure Call_Test_PI1_2 (A : access PI1'Class; I : out Integer); procedure Call_Test_PI1_1 (A : in out PI1'Class; I : out Integer) is begin Test_PI1_1 (A, I); end Call_Test_PI1_1; procedure Call_Test_PI1_2 (A : access PI1'Class; I : out Integer) is begin Test_PI1_2 (A, I); end Call_Test_PI1_2; I : Integer; begin Report.Test ("CY30032", "Protected interfaces with different parameter " & "modes (AI-345)"); -- ------------------------------------------------------------------------ Obj_Protected_1_PI1.Test_PI1_1 (I); if I /= 0 then Report.Failed ("Obj_Protected_1_PI1.Test_PI1_1 failed: expected 0, " & "returned " & Integer'Image (I)); else Report.Comment ("Obj_Protected_1_PI1.Test_PI1_1 passed"); end if; -- ------------------------------------------------------------------------ Obj_Protected_1_PI1.Test_PI1_2 (I); if I /= 1 then Report.Failed ("Obj_Protected_1_PI1.Test_PI1_2 failed: expected 1, " & "returned " & Integer'Image (I)); else Report.Comment ("Obj_Protected_1_PI1.Test_PI1_2 passed"); end if; -- ------------------------------------------------------------------------ Obj_Protected_2_PI1.Test_PI1_1 (I); if I /= 0 then Report.Failed ("Obj_Protected_2_PI1.Test_PI1_1 failed: expected 0, " & "returned " & Integer'Image (I)); else Report.Comment ("Obj_Protected_2_PI1.Test_PI1_1 passed"); end if; -- ------------------------------------------------------------------------ Obj_Protected_2_PI1.Test_PI1_2 (I); if I /= 1 then Report.Failed ("Obj_Protected_2_PI1.Test_PI1_2 failed: expected 1, " & "returned " & Integer'Image (I)); else Report.Comment ("Obj_Protected_2_PI1.Test_PI1_2 passed"); end if; -- ------------------------------------------------------------------------ Call_Test_PI1_1 (Obj_Protected_1_PI1, I); if I /= 0 then Report.Failed ("Call_Test_PI1_1 failed: expected 0, returned " & Integer'Image (I)); else Report.Comment ("Call_Test_PI1_1 passed"); end if; -- ------------------------------------------------------------------------ Call_Test_PI1_2 (Obj_Protected_2_PI1'access, I); if I /= 1 then Report.Failed ("Call_Test_PI1_2 failed: expected 1, returned " & Integer'Image (I)); else Report.Comment ("Call_Test_PI1_2 passed"); end if; Report.Result; end CY30032; package Ifaces is type PI1 is protected interface; procedure Test_PI1_1 (A : in out PI1; I : out Integer) is abstract; procedure Test_PI1_2 (B : access PI1; I : out Integer) is abstract; end Ifaces; with Ifaces; use Ifaces; package Implementations is protected type Protected_1_PI1 is new PI1 with entry Test_PI1_1 (I : out Integer); entry Test_PI1_2 (I : out Integer); end Protected_1_PI1; Obj_Protected_1_PI1 : Protected_1_PI1; Obj_Protected_2_PI1 : aliased Protected_1_PI1; end Implementations; package body Implementations is protected body Protected_1_PI1 is entry Test_PI1_1 (I : out Integer) when True is begin I := 0; end Test_PI1_1; entry Test_PI1_2 (I : out Integer) when True is begin I := 1; end Test_PI1_2; end Protected_1_PI1; end Implementations;