c94008c.ada

来自「用于进行gcc测试」· ADA 代码 · 共 266 行

-- C94008C.ADA

--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     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.  THE GOVERNMENT 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.
--*
-- CHECK THAT SELECT WITH TERMINATE ALTERNATIVE WORKS CORRECTLY WITH
-- NESTED TASKS.

-- THIS TEST CONTAINS RACE CONDITIONS AND USES A GENERIC INSTANCE THAT
-- CONTAINS TASKS.

-- JEAN-PIERRE ROSEN 24 FEBRUARY 1984
-- JRK 4/7/86
-- JBG 8/29/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT
-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.

with Impdef;
WITH REPORT; USE REPORT;
WITH SYSTEM; USE SYSTEM;
PROCEDURE C94008C IS


-- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES
     GENERIC
          TYPE HOLDER_TYPE IS PRIVATE;
          TYPE VALUE_TYPE IS PRIVATE;
          INITIAL_VALUE : HOLDER_TYPE;
          WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE;
                              VALUE  : IN  HOLDER_TYPE) IS <>;
          WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE;
                                 VALUE  : IN  VALUE_TYPE) IS <>;
     PACKAGE SHARED IS
          PROCEDURE SET (VALUE : IN HOLDER_TYPE);
          PROCEDURE UPDATE (VALUE : IN VALUE_TYPE);
          FUNCTION GET RETURN HOLDER_TYPE;
     END SHARED;

     PACKAGE BODY SHARED IS
          TASK SHARE IS
               ENTRY SET    (VALUE : IN HOLDER_TYPE);
               ENTRY UPDATE (VALUE : IN VALUE_TYPE);
               ENTRY READ   (VALUE : OUT HOLDER_TYPE);
          END SHARE;

          TASK BODY SHARE IS
               VARIABLE : HOLDER_TYPE;
          BEGIN
               LOOP
                    SELECT
                         ACCEPT SET (VALUE : IN HOLDER_TYPE) DO
                              SHARED.SET (VARIABLE, VALUE);
                         END SET;
                    OR
                         ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO
                              SHARED.UPDATE (VARIABLE, VALUE);
                         END UPDATE;
                    OR
                         ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO
                              VALUE := VARIABLE;
                         END READ;
                    OR
                         TERMINATE;
                    END SELECT;
               END LOOP;
          END SHARE;

          PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS
          BEGIN
               SHARE.SET (VALUE);
          END SET;

          PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS
          BEGIN
               SHARE.UPDATE (VALUE);
          END UPDATE;

          FUNCTION GET RETURN HOLDER_TYPE IS
               VALUE : HOLDER_TYPE;
          BEGIN
               SHARE.READ (VALUE);
               RETURN VALUE;
          END GET;

     BEGIN
          SHARE.SET (INITIAL_VALUE);    -- SET INITIAL VALUE
     END SHARED;

     PACKAGE EVENTS IS

          TYPE EVENT_TYPE IS
               RECORD
                    TRACE  : STRING (1..4) := "....";
                    LENGTH : NATURAL := 0;
               END RECORD;

          PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER);
          PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE);
     END EVENTS;

     PACKAGE COUNTER IS
          PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER);
          PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER);
     END COUNTER;

     PACKAGE BODY COUNTER IS
          PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS
          BEGIN
               VAR := VAR + VAL;
          END UPDATE;

          PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS
          BEGIN
               VAR := VAL;
          END SET;
     END COUNTER;

     PACKAGE BODY EVENTS IS
          PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS
          BEGIN
               VAR.LENGTH := VAR.LENGTH + 1;
               VAR.TRACE(VAR.LENGTH) := VAL;
          END UPDATE;

          PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS
          BEGIN
               VAR := VAL;
          END SET;

     END EVENTS;

     USE EVENTS, COUNTER;

     PACKAGE TRACE IS NEW SHARED (EVENT_TYPE, CHARACTER, ("....", 0));
     PACKAGE TERMINATE_COUNT IS NEW SHARED (INTEGER, INTEGER, 0);

     FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS
     BEGIN
          TERMINATE_COUNT.UPDATE (1);
          RETURN TRUE;
     END ENTER_TERMINATE;

BEGIN -- C94008C

     TEST ("C94008C", "CHECK CORRECT OPERATION OF SELECT WITH " &
                      "TERMINATE ALTERNATIVE");

     DECLARE

          PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE;

          TASK T1 IS
               ENTRY E1;
          END T1;

          TASK BODY T1 IS

               TASK T2 IS
                    ENTRY E2;
               END T2;

               TASK BODY T2 IS

                    TASK T3 IS
                         ENTRY E3;
                    END T3;

                    TASK BODY T3 IS
                    BEGIN
                         SELECT
                              ACCEPT E3;
                         OR WHEN ENTER_TERMINATE => TERMINATE;
                         END SELECT;
                         EVENT ('D');
                    END T3;

               BEGIN -- T2

                    SELECT
                         ACCEPT E2;
                    OR WHEN ENTER_TERMINATE => TERMINATE;
                    END SELECT;

                    DELAY 10.0 * Impdef.One_Second;

                    IF TERMINATE_COUNT.GET /= 1 THEN
                         DELAY 20.0 * Impdef.One_Second;
                    END IF;

                    IF TERMINATE_COUNT.GET /= 1 THEN
                         FAILED ("30 SECOND DELAY NOT ENOUGH - 1 ");
                    END IF;

                    EVENT ('C');
                    T1.E1;
                    T3.E3;
               END T2;

          BEGIN -- T1;

               SELECT
                    ACCEPT E1;
               OR WHEN ENTER_TERMINATE => TERMINATE;
               END SELECT;

               EVENT ('B');
               TERMINATE_COUNT.SET (0);
               T2.E2;

               SELECT
                    ACCEPT E1;
               OR WHEN ENTER_TERMINATE => TERMINATE;
               END SELECT;

               SELECT
                    ACCEPT E1;
               OR TERMINATE;  -- ONLY THIS ONE EVER CHOSEN.
               END SELECT;

               FAILED ("TERMINATE NOT SELECTED IN T1");
          END T1;

     BEGIN

          DELAY 10.0 * Impdef.One_Second; -- WAIT FOR T1, T2, AND T3 TO GET TO SELECT STMTS.

           IF TERMINATE_COUNT.GET /= 3 THEN
                DELAY 20.0 * Impdef.One_Second;
           END IF;

           IF TERMINATE_COUNT.GET /= 3 THEN
                FAILED ("30 SECOND DELAY NOT ENOUGH - 2");
           END IF;

          EVENT ('A');
          T1.E1;

     EXCEPTION
          WHEN OTHERS => FAILED ("EXCEPTION IN MAIN BLOCK");
     END;

     IF TRACE.GET.TRACE /= "ABCD" THEN
          FAILED ("INCORRECT ORDER OF EVENTS: " & TRACE.GET.TRACE);
     END IF;

     RESULT;
END C94008C;