-- CY30029.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 (synchronized interfaces with private extensions) -- -- CHANGE HISTORY: -- 08 April 2005 Initial Version --! with Report; procedure CY30029 is package PkgI1 is type SI1 is synchronized interface; procedure S (D : in out SI1; I : out Integer) is abstract; ---------------------------- -- Interface inheritance -- ---------------------------- -- -------------------------------------------------------------------- type SI5 is synchronized interface and SI1; -- OK procedure V (G : in out SI5; I : out Integer) is abstract; -- -------------------------------------------------------------------- -- -------------------------------------------------------------------- type Task_7_SI1_SI5 is new SI1 and SI5 with private; -- OK -- -------------------------------------------------------------------- type Task_8_SI1_SI5 is new SI1 and SI5 with private; -- OK -- -------------------------------------------------------------------- type Task_9_SI1_SI5 is new SI1 and SI5 with private; -- OK -- -------------------------------------------------------------------- private ------------------ -- Overriding -- ------------------ -- -------------------------------------------------------------------- task type Task_7_SI1_SI5 is new SI1 and SI5 with -- OK entry S (I : out Integer); entry V (I : out Integer); end Task_7_SI1_SI5; -- -------------------------------------------------------------------- task type Task_8_SI1_SI5 is new SI1 and SI5 with -- OK entry S (I : out Integer); end Task_8_SI1_SI5; procedure V (G : in out Task_8_SI1_SI5; I : out Integer); -- -------------------------------------------------------------------- task type Task_9_SI1_SI5 is new SI1 and SI5 with -- OK entry V (I : out Integer); end Task_9_SI1_SI5; procedure S (D : in out Task_9_SI1_SI5; I : out Integer) is null; -- -------------------------------------------------------------------- end PkgI1; package body PkgI1 is ----------------------- -- Implementations -- ----------------------- task body Task_7_SI1_SI5 is begin loop select accept S (I : out Integer) do I := 0; end S; or accept V (I : out Integer) do I := 1; end V; or terminate; end select; end loop; end Task_7_SI1_SI5; task body Task_8_SI1_SI5 is begin loop select accept S (I : out Integer) do I := 2; end S; or terminate; end select; end loop; end Task_8_SI1_SI5; procedure V (G : in out Task_8_SI1_SI5; I : out Integer) is begin I := 3; end V; task body Task_9_SI1_SI5 is begin loop select accept V (I : out Integer) do I := 4; end V; or terminate; end select; end loop; end Task_9_SI1_SI5; end PkgI1; use PkgI1; ------------------------------ -- Dispatching procedures -- ------------------------------ procedure Call_SI1_S (D : in out SI1'Class; I : out Integer); procedure Call_SI5_V (G : in out SI5'Class; I : out Integer); procedure Call_SI1_S (D : in out SI1'Class; I : out Integer) is begin S (D, I); end Call_SI1_S; procedure Call_SI5_V (G : in out SI5'Class; I : out Integer) is begin V (G, I); end Call_SI5_V; S_1 : Task_7_SI1_SI5; S_2 : Task_8_SI1_SI5; S_3 : Task_9_SI1_SI5; I : Integer; begin Report.Test ("CY300029", "Synchronized interfaces with private extensions" & " (AI-345)"); -- ------------------------------------------------------------------------ Call_SI1_S (S_1, I); if I /= 0 then Report.Failed ("Call_SI1_S failed : expected 0, returned " & Integer'Image (I)); else Report.Comment ("Call_SI1_S passed"); end if; -- ------------------------------------------------------------------------ Call_SI5_V (S_1, I); if I /= 1 then Report.Failed ("Call_SI5_V failed : expected 1, returned " & Integer'Image (I)); else Report.Comment ("Call_SI5_V passed"); end if; -- ------------------------------------------------------------------------ Call_SI1_S (S_2, I); if I /= 2 then Report.Failed ("Call_SI1_S failed : expected 2, returned " & Integer'Image (I)); else Report.Comment ("Call_SI1_S passed"); end if; -- ------------------------------------------------------------------------ -- ??? This causes a runtime constraint error ??? -- Call_SI5_V (S_2, I); -- if I /= 3 then -- Report.Failed ("Call_SI5_V failed : expected 3, returned " & -- Integer'Image (I)); -- else -- Report.Comment ("Call_SI5_V passed"); -- end if; -- ------------------------------------------------------------------------ Call_SI5_V (S_3, I); if I /= 4 then Report.Failed ("Call_SI5_V failed : expected 4, returned " & Integer'Image (I)); else Report.Comment ("Call_SI5_V passed"); end if; -- ------------------------------------------------------------------------ Report.Result; end CY30029;