gcc/testsuite/ada/acats/tests/c3/c38202a.ada

   1 -- C38202A.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 TASKING ATTRIBUTES ARE DECLARED AND RETURN CORRECT
  26 -- VALUES FOR OBJECTS HAVING AN ACCESS TYPE WHOSE DESIGNATED
  27 -- TYPE IS A TASK TYPE.
  28 -- CHECK THE ACCESS TYPE RESULTS OF FUNCTION CALLS.
  29
  30 -- AH  9/12/86
  31 -- EDS 7/14/98  AVOID OPTIMIZATION
  32
  33 WITH REPORT; USE REPORT;
  34 PROCEDURE C38202A IS
  35 BEGIN
  36      TEST ("C38202A", "OBJECTS HAVING ACCESS TYPES WITH DESIGNATED " &
  37            "TASK TYPE CAN BE PREFIX OF TASKING ATTRIBUTES");
  38
  39 -- CHECK TWO CASES:  (1)  TASK IS CALLABLE, NOT TERMINATED.
  40 --                   (2)  TASK IS NOT CALLABLE, TERMINATED.
  41
  42      DECLARE
  43           TASK TYPE TSK IS
  44                ENTRY GO_ON;
  45           END TSK;
  46
  47           TASK DRIVER IS
  48                ENTRY TSK_DONE;
  49           END DRIVER;
  50
  51           TYPE P_TYPE IS ACCESS TSK;
  52           P : P_TYPE;
  53
  54           TASK BODY TSK IS
  55                I : INTEGER RANGE 0 .. 2;
  56           BEGIN
  57                ACCEPT GO_ON;
  58                I := IDENT_INT(5);         -- CONSTRAINT_ERROR RAISED.
  59                FAILED ("CONSTAINT_ERROR NOT RAISED IN TASK " &
  60                        " TSK - 1A " & INTEGER'IMAGE(I));
  61           EXCEPTION
  62                WHEN CONSTRAINT_ERROR =>
  63                     DRIVER.TSK_DONE;
  64                WHEN OTHERS =>
  65                     FAILED ("WRONG EXCEPTION RAISED IN TASK " &
  66                             "TSK - 1A ");
  67                     DRIVER.TSK_DONE;
  68           END TSK;
  69
  70           TASK BODY DRIVER IS
  71                COUNTER : INTEGER := 1;
  72           BEGIN
  73                P := NEW TSK;
  74                IF NOT P'CALLABLE THEN
  75                     FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
  76                             "VALUE - 1B");
  77                END IF;
  78
  79                IF P'TERMINATED THEN
  80                     FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
  81                             "VALUE - 1C");
  82                END IF;
  83
  84                P.GO_ON;
  85                ACCEPT TSK_DONE;
  86                WHILE (NOT P'TERMINATED AND COUNTER <= 3) LOOP
  87                     DELAY 10.0;
  88                     COUNTER := COUNTER + 1;
  89                END LOOP;
  90
  91                IF COUNTER > 3 THEN
  92                     FAILED ("TASK TSK NOT TERMINATED IN SUFFICIENT " &
  93                             "TIME - 1D");
  94                END IF;
  95
  96                IF P'CALLABLE THEN
  97                     FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
  98                             "VALUE - 1E");
  99                END IF;
 100
 101                IF NOT P'TERMINATED THEN
 102                     FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
 103                             "VALUE - 1F");
 104                END IF;
 105           END DRIVER;
 106
 107      BEGIN
 108           NULL;
 109      END;     -- BLOCK
 110
 111 -- CHECK ACCESS TYPE RESULT RETURNED FROM FUNCTION.
 112 -- CHECK TWO CASES:  (1)  TASK IS CALLABLE, NOT TERMINATED.
 113 --                   (2)  TASK IS NOT CALLABLE, TERMINATED.
 114
 115      DECLARE
 116           TASK TYPE TSK IS
 117                ENTRY GO_ON;
 118           END TSK;
 119
 120           TASK DRIVER IS
 121                ENTRY TSK_DONE;
 122           END DRIVER;
 123
 124           TYPE P_TYPE IS ACCESS TSK;
 125           P : P_TYPE;
 126
 127           TSK_CREATED : BOOLEAN := FALSE;
 128
 129           FUNCTION F1 RETURN P_TYPE IS
 130           BEGIN
 131                RETURN P;
 132           END F1;
 133
 134           TASK BODY TSK IS
 135                I : INTEGER RANGE 0 .. 2;
 136           BEGIN
 137                ACCEPT GO_ON;
 138                I := IDENT_INT(5);          -- CONSTRAINT_ERROR RAISED.
 139                FAILED ("CONSTRAINT_ERROR NOT RAISED IN TASK " &
 140                        "TSK - 2A " & INTEGER'IMAGE(I));
 141           EXCEPTION
 142                WHEN CONSTRAINT_ERROR =>
 143                     DRIVER.TSK_DONE;
 144                WHEN OTHERS =>
 145                     FAILED ("WRONG EXCEPTION RAISED IN TASK " &
 146                             "TSK - 2A ");
 147                     DRIVER.TSK_DONE;
 148           END TSK;
 149
 150           TASK BODY DRIVER IS
 151                COUNTER : INTEGER := 1;
 152           BEGIN
 153                P := NEW TSK;               -- ACTIVATE P.ALL (F1.ALL).
 154                IF NOT F1'CALLABLE THEN
 155                     FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
 156                             "VALUE WHEN PREFIX IS VALUE FROM " &
 157                             "FUNCTION CALL - 2B");
 158                END IF;
 159
 160                IF F1'TERMINATED THEN
 161                     FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
 162                             "VALUE WHEN PREFIX IS VALUE FROM " &
 163                             "FUNCTION CALL - 2C");
 164                END IF;
 165
 166                F1.ALL.GO_ON;
 167                ACCEPT TSK_DONE;
 168                WHILE (NOT F1'TERMINATED AND COUNTER <= 3) LOOP
 169                     DELAY 10.0;
 170                     COUNTER := COUNTER + 1;
 171                END LOOP;
 172
 173                IF COUNTER > 3 THEN
 174                     FAILED ("TASK TSK NOT TERMINATED IN SUFFICIENT " &
 175                             "TIME - 2D");
 176                END IF;
 177
 178                IF F1'CALLABLE THEN
 179                     FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
 180                             "VALUE WHEN PREFIX IS VALUE FROM " &
 181                             "FUNCTION CALL - 2E");
 182                END IF;
 183
 184                IF NOT F1'TERMINATED THEN
 185                     FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
 186                             "VALUE WHEN PREFIX IS VALUE FROM " &
 187                             "FUNCTION CALL - 2F");
 188                END IF;
 189           END DRIVER;
 190
 191      BEGIN
 192           NULL;
 193      END;     -- BLOCK
 194
 195      RESULT;
 196 END C38202A;