gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c34008a.ada

   1 -- C34008A.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
  27 --     (IMPLICITLY) FOR DERIVED TASK TYPES.
  28
  29 -- HISTORY:
  30 --     JRK 08/27/87  CREATED ORIGINAL TEST.
  31 --     PWN 11/30/94  REMOVED 'BASE USE ILLEGAL IN ADA 9X.
  32 --     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  33 --     DTN 11/30/95  REMOVED ATTIBUTES OF NON-OBJECTS.
  34
  35 WITH SYSTEM; USE SYSTEM;
  36 WITH REPORT; USE REPORT;
  37
  38 PROCEDURE C34008A IS
  39
  40      PACKAGE PKG IS
  41
  42           TASK TYPE PARENT IS
  43                ENTRY E (I : IN OUT INTEGER);
  44                ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER);
  45                ENTRY G;
  46                ENTRY H (1 .. 3);
  47                ENTRY R (I : OUT INTEGER);
  48                ENTRY W (I : INTEGER);
  49           END PARENT;
  50
  51           FUNCTION ID (X : PARENT) RETURN INTEGER;
  52
  53      END PKG;
  54
  55      USE PKG;
  56
  57      TYPE T IS NEW PARENT;
  58
  59      TASK TYPE AUX;
  60
  61      X : T;
  62      W : PARENT;
  63      B : BOOLEAN := FALSE;
  64      I : INTEGER := 0;
  65      J : INTEGER := 0;
  66      A1, A2 : AUX;
  67
  68      PROCEDURE A (X : ADDRESS) IS
  69      BEGIN
  70           B := IDENT_BOOL (TRUE);
  71      END A;
  72
  73      FUNCTION V RETURN T IS
  74      BEGIN
  75           RETURN X;
  76      END V;
  77
  78      PACKAGE BODY PKG IS
  79
  80           TASK BODY PARENT IS
  81                N : INTEGER := 1;
  82           BEGIN
  83                LOOP
  84                     SELECT
  85                          ACCEPT E (I : IN OUT INTEGER) DO
  86                               I := I + N;
  87                          END E;
  88                     OR
  89                          ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO
  90                               J := I + N;
  91                          END F;
  92                     OR
  93                          ACCEPT G DO
  94                               WHILE H(2)'COUNT < 2 LOOP
  95                                    DELAY 5.0;
  96                               END LOOP;
  97                               ACCEPT H (2) DO
  98                                    IF E'COUNT    /= 0 OR
  99                                       F(1)'COUNT /= 0 OR
 100                                       F(2)'COUNT /= 0 OR
 101                                       F(3)'COUNT /= 0 OR
 102                                       G'COUNT    /= 0 OR
 103                                       H(1)'COUNT /= 0 OR
 104                                       H(2)'COUNT /= 1 OR
 105                                       H(3)'COUNT /= 0 OR
 106                                       R'COUNT    /= 0 OR
 107                                       W'COUNT    /= 0 THEN
 108                                         FAILED ("INCORRECT 'COUNT");
 109                                    END IF;
 110                               END H;
 111                               ACCEPT H (2);
 112                          END G;
 113                     OR
 114                          ACCEPT R (I : OUT INTEGER) DO
 115                               I := N;
 116                          END R;
 117                     OR
 118                          ACCEPT W (I : INTEGER) DO
 119                               N := I;
 120                          END W;
 121                     OR
 122                          TERMINATE;
 123                     END SELECT;
 124                END LOOP;
 125           END PARENT;
 126
 127           FUNCTION ID (X : PARENT) RETURN INTEGER IS
 128                I : INTEGER;
 129           BEGIN
 130                X.R (I);
 131                RETURN I;
 132           END ID;
 133
 134      END PKG;
 135
 136      TASK BODY AUX IS
 137      BEGIN
 138           X.H (2);
 139      END AUX;
 140
 141 BEGIN
 142      TEST ("C34008A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
 143                       "ARE DECLARED (IMPLICITLY) FOR DERIVED TASK " &
 144                       "TYPES");
 145
 146      X.W (IDENT_INT (2));
 147      IF ID (X) /= 2 THEN
 148           FAILED ("INCORRECT INITIALIZATION");
 149      END IF;
 150
 151      IF ID (T'(X)) /= 2 THEN
 152           FAILED ("INCORRECT QUALIFICATION");
 153      END IF;
 154
 155      IF ID (T (X)) /= 2 THEN
 156           FAILED ("INCORRECT SELF CONVERSION");
 157      END IF;
 158
 159      W.W (IDENT_INT (3));
 160      IF ID (T (W)) /= 3 THEN
 161           FAILED ("INCORRECT CONVERSION FROM PARENT");
 162      END IF;
 163
 164      IF ID (PARENT (X)) /= 2 THEN
 165           FAILED ("INCORRECT CONVERSION TO PARENT");
 166      END IF;
 167
 168      I := 5;
 169      X.E (I);
 170      IF I /= 7 THEN
 171           FAILED ("INCORRECT SELECTION (ENTRY)");
 172      END IF;
 173
 174      I := 5;
 175      X.F (IDENT_INT (2)) (I, J);
 176      IF J /= 7 THEN
 177           FAILED ("INCORRECT SELECTION (FAMILY)");
 178      END IF;
 179
 180      IF NOT (X IN T) THEN
 181           FAILED ("INCORRECT ""IN""");
 182      END IF;
 183
 184      IF X NOT IN T THEN
 185           FAILED ("INCORRECT ""NOT IN""");
 186      END IF;
 187
 188
 189      B := FALSE;
 190      A (X'ADDRESS);
 191      IF NOT B THEN
 192           FAILED ("INCORRECT OBJECT'ADDRESS");
 193      END IF;
 194
 195      IF NOT X'CALLABLE THEN
 196           FAILED ("INCORRECT OBJECT'CALLABLE");
 197      END IF;
 198
 199      IF NOT V'CALLABLE THEN
 200           FAILED ("INCORRECT VALUE'CALLABLE");
 201      END IF;
 202
 203      X.G;
 204
 205      IF X'SIZE < T'SIZE THEN
 206           FAILED ("INCORRECT OBJECT'SIZE");
 207      END IF;
 208
 209      IF T'STORAGE_SIZE < 0 THEN
 210           FAILED ("INCORRECT TYPE'STORAGE_SIZE");
 211      END IF;
 212
 213      IF X'STORAGE_SIZE < 0 THEN
 214           FAILED ("INCORRECT OBJECT'STORAGE_SIZE");
 215      END IF;
 216
 217      IF X'TERMINATED THEN
 218           FAILED ("INCORRECT OBJECT'TERMINATED");
 219      END IF;
 220
 221      IF V'TERMINATED THEN
 222           FAILED ("INCORRECT VALUE'TERMINATED");
 223      END IF;
 224
 225      RESULT;
 226 END C34008A;