gcc/testsuite/ada/acats/tests/c9/c94008c.ada

   1 -- C94008C.ADA
   2
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 -- CHECK THAT SELECT WITH TERMINATE ALTERNATIVE WORKS CORRECTLY WITH
  26 -- NESTED TASKS.
  27
  28 -- THIS TEST CONTAINS RACE CONDITIONS AND USES A GENERIC INSTANCE THAT
  29 -- CONTAINS TASKS.
  30
  31 -- JEAN-PIERRE ROSEN 24 FEBRUARY 1984
  32 -- JRK 4/7/86
  33 -- JBG 8/29/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT
  34 -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
  35
  36 with Impdef;
  37 WITH REPORT; USE REPORT;
  38 WITH SYSTEM; USE SYSTEM;
  39 PROCEDURE C94008C IS
  40
  41
  42 -- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES
  43      GENERIC
  44           TYPE HOLDER_TYPE IS PRIVATE;
  45           TYPE VALUE_TYPE IS PRIVATE;
  46           INITIAL_VALUE : HOLDER_TYPE;
  47           WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE;
  48                               VALUE  : IN  HOLDER_TYPE) IS <>;
  49           WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE;
  50                                  VALUE  : IN  VALUE_TYPE) IS <>;
  51      PACKAGE SHARED IS
  52           PROCEDURE SET (VALUE : IN HOLDER_TYPE);
  53           PROCEDURE UPDATE (VALUE : IN VALUE_TYPE);
  54           FUNCTION GET RETURN HOLDER_TYPE;
  55      END SHARED;
  56
  57      PACKAGE BODY SHARED IS
  58           TASK SHARE IS
  59                ENTRY SET    (VALUE : IN HOLDER_TYPE);
  60                ENTRY UPDATE (VALUE : IN VALUE_TYPE);
  61                ENTRY READ   (VALUE : OUT HOLDER_TYPE);
  62           END SHARE;
  63
  64           TASK BODY SHARE IS
  65                VARIABLE : HOLDER_TYPE;
  66           BEGIN
  67                LOOP
  68                     SELECT
  69                          ACCEPT SET (VALUE : IN HOLDER_TYPE) DO
  70                               SHARED.SET (VARIABLE, VALUE);
  71                          END SET;
  72                     OR
  73                          ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO
  74                               SHARED.UPDATE (VARIABLE, VALUE);
  75                          END UPDATE;
  76                     OR
  77                          ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO
  78                               VALUE := VARIABLE;
  79                          END READ;
  80                     OR
  81                          TERMINATE;
  82                     END SELECT;
  83                END LOOP;
  84           END SHARE;
  85
  86           PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS
  87           BEGIN
  88                SHARE.SET (VALUE);
  89           END SET;
  90
  91           PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS
  92           BEGIN
  93                SHARE.UPDATE (VALUE);
  94           END UPDATE;
  95
  96           FUNCTION GET RETURN HOLDER_TYPE IS
  97                VALUE : HOLDER_TYPE;
  98           BEGIN
  99                SHARE.READ (VALUE);
 100                RETURN VALUE;
 101           END GET;
 102
 103      BEGIN
 104           SHARE.SET (INITIAL_VALUE);    -- SET INITIAL VALUE
 105      END SHARED;
 106
 107      PACKAGE EVENTS IS
 108
 109           TYPE EVENT_TYPE IS
 110                RECORD
 111                     TRACE  : STRING (1..4) := "....";
 112                     LENGTH : NATURAL := 0;
 113                END RECORD;
 114
 115           PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER);
 116           PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE);
 117      END EVENTS;
 118
 119      PACKAGE COUNTER IS
 120           PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER);
 121           PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER);
 122      END COUNTER;
 123
 124      PACKAGE BODY COUNTER IS
 125           PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS
 126           BEGIN
 127                VAR := VAR + VAL;
 128           END UPDATE;
 129
 130           PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS
 131           BEGIN
 132                VAR := VAL;
 133           END SET;
 134      END COUNTER;
 135
 136      PACKAGE BODY EVENTS IS
 137           PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS
 138           BEGIN
 139                VAR.LENGTH := VAR.LENGTH + 1;
 140                VAR.TRACE(VAR.LENGTH) := VAL;
 141           END UPDATE;
 142
 143           PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS
 144           BEGIN
 145                VAR := VAL;
 146           END SET;
 147
 148      END EVENTS;
 149
 150      USE EVENTS, COUNTER;
 151
 152      PACKAGE TRACE IS NEW SHARED (EVENT_TYPE, CHARACTER, ("....", 0));
 153      PACKAGE TERMINATE_COUNT IS NEW SHARED (INTEGER, INTEGER, 0);
 154
 155      FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS
 156      BEGIN
 157           TERMINATE_COUNT.UPDATE (1);
 158           RETURN TRUE;
 159      END ENTER_TERMINATE;
 160
 161 BEGIN -- C94008C
 162
 163      TEST ("C94008C", "CHECK CORRECT OPERATION OF SELECT WITH " &
 164                       "TERMINATE ALTERNATIVE");
 165
 166      DECLARE
 167
 168           PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE;
 169
 170           TASK T1 IS
 171                ENTRY E1;
 172           END T1;
 173
 174           TASK BODY T1 IS
 175
 176                TASK T2 IS
 177                     ENTRY E2;
 178                END T2;
 179
 180                TASK BODY T2 IS
 181
 182                     TASK T3 IS
 183                          ENTRY E3;
 184                     END T3;
 185
 186                     TASK BODY T3 IS
 187                     BEGIN
 188                          SELECT
 189                               ACCEPT E3;
 190                          OR WHEN ENTER_TERMINATE => TERMINATE;
 191                          END SELECT;
 192                          EVENT ('D');
 193                     END T3;
 194
 195                BEGIN -- T2
 196
 197                     SELECT
 198                          ACCEPT E2;
 199                     OR WHEN ENTER_TERMINATE => TERMINATE;
 200                     END SELECT;
 201
 202                     DELAY 10.0 * Impdef.One_Second;
 203
 204                     IF TERMINATE_COUNT.GET /= 1 THEN
 205                          DELAY 20.0 * Impdef.One_Long_Second;
 206                     END IF;
 207
 208                     IF TERMINATE_COUNT.GET /= 1 THEN
 209                          FAILED ("30 SECOND DELAY NOT ENOUGH - 1 ");
 210                     END IF;
 211
 212                     EVENT ('C');
 213                     T1.E1;
 214                     T3.E3;
 215                END T2;
 216
 217           BEGIN -- T1;
 218
 219                SELECT
 220                     ACCEPT E1;
 221                OR WHEN ENTER_TERMINATE => TERMINATE;
 222                END SELECT;
 223
 224                EVENT ('B');
 225                TERMINATE_COUNT.SET (0);
 226                T2.E2;
 227
 228                SELECT
 229                     ACCEPT E1;
 230                OR WHEN ENTER_TERMINATE => TERMINATE;
 231                END SELECT;
 232
 233                SELECT
 234                     ACCEPT E1;
 235                OR TERMINATE;  -- ONLY THIS ONE EVER CHOSEN.
 236                END SELECT;
 237
 238                FAILED ("TERMINATE NOT SELECTED IN T1");
 239           END T1;
 240
 241      BEGIN
 242
 243           DELAY 10.0 * Impdef.One_Second; -- WAIT FOR T1, T2, AND T3 TO GET TO SELECT STMTS.
 244
 245            IF TERMINATE_COUNT.GET /= 3 THEN
 246                 DELAY 20.0 * Impdef.One_Long_Second;
 247            END IF;
 248
 249            IF TERMINATE_COUNT.GET /= 3 THEN
 250                 FAILED ("30 SECOND DELAY NOT ENOUGH - 2");
 251            END IF;
 252
 253           EVENT ('A');
 254           T1.E1;
 255
 256      EXCEPTION
 257           WHEN OTHERS => FAILED ("EXCEPTION IN MAIN BLOCK");
 258      END;
 259
 260      IF TRACE.GET.TRACE /= "ABCD" THEN
 261           FAILED ("INCORRECT ORDER OF EVENTS: " & TRACE.GET.TRACE);
 262      END IF;
 263
 264      RESULT;
 265 END C94008C;