old-autovect-branch/gcc/testsuite/ada/acats/tests/c9/c94007a.ada

   1 -- C94007A.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 -- OBJECTIVE:
  26 --     CHECK THAT A TASK THAT IS DECLARED IN A NON-LIBRARY PACKAGE
  27 --     (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE,
  28 --     BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY,
  29 --     OR TASK BODY.
  30 --     SUBTESTS ARE:
  31 --       (A)  A SIMPLE TASK OBJECT, IN A VISIBLE PART, IN A BLOCK.
  32 --       (B)  AN ARRAY OF TASK OBJECT, IN A PRIVATE PART, IN A FUNCTION.
  33 --       (C)  AN ARRAY OF RECORD OF TASK OBJECT, IN A PACKAGE BODY,
  34 --            IN A TASK BODY.
  35
  36 -- HISTORY:
  37 --     JRK 10/13/81
  38 --     SPS 11/21/82
  39 --     DHH 09/07/88 REVISED HEADER, ADDED EXCEPTION HANDLERS ON OUTER
  40 --                  BLOCKS, AND ADDED CASE TO INSURE THAT LEAVING A
  41 --                  PACKAGE VIA AN EXCEPTION WOULD NOT ABORT TASKS.
  42 --     PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X.
  43
  44 with Impdef;
  45 WITH REPORT; USE REPORT;
  46 WITH SYSTEM; USE SYSTEM;
  47 PROCEDURE C94007A IS
  48
  49      TASK TYPE SYNC IS
  50           ENTRY ID (C : CHARACTER);
  51           ENTRY INNER;
  52           ENTRY OUTER;
  53      END SYNC;
  54
  55      TASK BODY SYNC IS
  56           ID_C : CHARACTER;
  57      BEGIN
  58           ACCEPT ID (C : CHARACTER) DO
  59                ID_C := C;
  60           END ID;
  61           DELAY 1.0 * Impdef.One_Second;
  62           SELECT
  63                ACCEPT OUTER;
  64           OR
  65                DELAY 120.0 * Impdef.One_Second;
  66                FAILED ("PROBABLY BLOCKED - (" & ID_C & ')');
  67           END SELECT;
  68           ACCEPT INNER;
  69      END SYNC;
  70
  71
  72 BEGIN
  73      TEST ("C94007A", "CHECK THAT A TASK THAT IS DECLARED IN A " &
  74                       "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " &
  75                       "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " &
  76                       "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " &
  77                       "BODY, OR TASK BODY");
  78
  79      --------------------------------------------------
  80
  81      DECLARE -- (A)
  82
  83           S : SYNC;
  84
  85      BEGIN -- (A)
  86
  87           S.ID ('A');
  88
  89           DECLARE
  90
  91                PACKAGE PKG IS
  92                     TASK T IS
  93                          ENTRY E;
  94                     END T;
  95                END PKG;
  96
  97                PACKAGE BODY PKG IS
  98                     TASK BODY T IS
  99                     BEGIN
 100                          S.INNER;  -- PROBABLE INNER BLOCK POINT.
 101                     END T;
 102                END PKG;            -- PROBABLE OUTER BLOCK POINT.
 103
 104           BEGIN
 105
 106                S.OUTER;
 107
 108           EXCEPTION
 109                WHEN TASKING_ERROR => NULL;
 110           END;
 111
 112      EXCEPTION
 113           WHEN OTHERS =>
 114                FAILED("UNEXPECTED EXCEPTION RAISED - A");
 115      END; -- (A)
 116
 117      --------------------------------------------------
 118
 119      DECLARE -- (B)
 120
 121           S : SYNC;
 122
 123           I : INTEGER;
 124
 125           FUNCTION F RETURN INTEGER IS
 126
 127                PACKAGE PKG IS
 128                PRIVATE
 129                     TASK TYPE TT IS
 130                          ENTRY E;
 131                     END TT;
 132                     A : ARRAY (1..1) OF TT;
 133                END PKG;
 134
 135                PACKAGE BODY PKG IS
 136                     TASK BODY TT IS
 137                     BEGIN
 138                          S.INNER;  -- PROBABLE INNER BLOCK POINT.
 139                     END TT;
 140                END PKG;            -- PROBABLE OUTER BLOCK POINT.
 141
 142           BEGIN -- F
 143
 144                S.OUTER;
 145                RETURN 0;
 146
 147           EXCEPTION
 148                WHEN TASKING_ERROR => RETURN 0;
 149           END F;
 150
 151      BEGIN -- (B)
 152
 153           S.ID ('B');
 154           I := F;
 155
 156      EXCEPTION
 157           WHEN OTHERS =>
 158                FAILED("UNEXPECTED EXCEPTION RAISED - B");
 159
 160      END; -- (B)
 161
 162      --------------------------------------------------
 163
 164      DECLARE -- (C)
 165
 166           S : SYNC;
 167
 168      BEGIN -- (C)
 169
 170           S.ID ('C');
 171
 172           DECLARE
 173
 174                TASK TSK IS
 175                END TSK;
 176
 177                TASK BODY TSK IS
 178
 179                     PACKAGE PKG IS
 180                     END PKG;
 181
 182                     PACKAGE BODY PKG IS
 183                          TASK TYPE TT IS
 184                               ENTRY E;
 185                          END TT;
 186
 187                          TYPE RT IS
 188                               RECORD
 189                                    T : TT;
 190                               END RECORD;
 191
 192                          AR : ARRAY (1..1) OF RT;
 193
 194                          TASK BODY TT IS
 195                          BEGIN
 196                               S.INNER;  -- PROBABLE INNER BLOCK POINT.
 197                          END TT;
 198                     END PKG;            -- PROBABLE OUTER BLOCK POINT.
 199
 200                BEGIN -- TSK
 201
 202                     S.OUTER;
 203
 204                EXCEPTION
 205                     WHEN TASKING_ERROR => NULL;
 206                END TSK;
 207
 208           BEGIN
 209                NULL;
 210           END;
 211
 212      EXCEPTION
 213           WHEN OTHERS =>
 214                FAILED("UNEXPECTED EXCEPTION RAISED - C");
 215      END; -- (C)
 216
 217      --------------------------------------------------
 218
 219      DECLARE -- (D)
 220
 221      GLOBAL : INTEGER := IDENT_INT(5);
 222
 223      BEGIN -- (D)
 224
 225           DECLARE
 226
 227                PACKAGE PKG IS
 228                     TASK T IS
 229                          ENTRY E;
 230                     END T;
 231
 232                     TASK T1 IS
 233                     END T1;
 234                END PKG;
 235
 236                PACKAGE BODY PKG IS
 237                     TASK BODY T IS
 238                     BEGIN
 239                          ACCEPT E DO
 240                               RAISE CONSTRAINT_ERROR;
 241                          END E;
 242                     END T;
 243
 244                     TASK BODY T1 IS
 245                     BEGIN
 246                          DELAY 120.0 * Impdef.One_Second;
 247                          GLOBAL := IDENT_INT(1);
 248                     END T1;
 249
 250                BEGIN
 251                     T.E;
 252
 253                END PKG;
 254                USE PKG;
 255           BEGIN
 256                NULL;
 257           END;
 258
 259      EXCEPTION
 260           WHEN CONSTRAINT_ERROR =>
 261                IF GLOBAL /= IDENT_INT(1) THEN
 262                     FAILED("TASK NOT COMPLETED");
 263                END IF;
 264
 265           WHEN OTHERS =>
 266                FAILED("UNEXPECTED EXCEPTION RAISED - D");
 267      END; -- (D)
 268
 269      RESULT;
 270 END C94007A;