old-autovect-branch/gcc/testsuite/ada/acats/tests/c8/c85005d.ada

   1 -- C85005D.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 VARIABLE CREATED BY A GENERIC 'IN OUT' FORMAL
  27 --     PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND
  28 --     THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND
  29 --     PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT'
  30 --     PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER,
  31 --     AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED,
  32 --     THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME.
  33
  34 -- HISTORY:
  35 --     JET 03/15/88  CREATED ORIGINAL TEST.
  36
  37 WITH REPORT; USE REPORT;
  38 PROCEDURE C85005D IS
  39
  40      TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
  41      TYPE RECORD1 (D : INTEGER) IS
  42           RECORD
  43                FIELD1 : INTEGER := 1;
  44           END RECORD;
  45      TYPE POINTER1 IS ACCESS INTEGER;
  46
  47      PACKAGE PACK1 IS
  48           TYPE PRIVY IS PRIVATE;
  49           ZERO : CONSTANT PRIVY;
  50           ONE : CONSTANT PRIVY;
  51           TWO : CONSTANT PRIVY;
  52           THREE : CONSTANT PRIVY;
  53           FOUR : CONSTANT PRIVY;
  54           FIVE : CONSTANT PRIVY;
  55           FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
  56           FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
  57      PRIVATE
  58           TYPE PRIVY IS RANGE 0..127;
  59           ZERO : CONSTANT PRIVY := 0;
  60           ONE : CONSTANT PRIVY := 1;
  61           TWO : CONSTANT PRIVY := 2;
  62           THREE : CONSTANT PRIVY := 3;
  63           FOUR : CONSTANT PRIVY := 4;
  64           FIVE : CONSTANT PRIVY := 5;
  65      END PACK1;
  66
  67      TASK TYPE TASK1 IS
  68           ENTRY ASSIGN (J : IN INTEGER);
  69           ENTRY VALU (J : OUT INTEGER);
  70           ENTRY NEXT;
  71           ENTRY STOP;
  72      END TASK1;
  73
  74      DI1 : INTEGER := 0;
  75      DA1 : ARRAY1(1..3) := (OTHERS => 0);
  76      DR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
  77      DP1 : POINTER1 := NEW INTEGER'(0);
  78      DV1 : PACK1.PRIVY := PACK1.ZERO;
  79      DT1 : TASK1;
  80
  81      I : INTEGER;
  82
  83      GENERIC
  84           GI1 : IN OUT INTEGER;
  85           GA1 : IN OUT ARRAY1;
  86           GR1 : IN OUT RECORD1;
  87           GP1 : IN OUT POINTER1;
  88           GV1 : IN OUT PACK1.PRIVY;
  89           GT1 : IN OUT TASK1;
  90      PACKAGE GENERIC1 IS
  91      END GENERIC1;
  92
  93      FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
  94      BEGIN
  95           IF EQUAL (3,3) THEN
  96                RETURN P;
  97           ELSE
  98                RETURN NULL;
  99           END IF;
 100      END IDENT;
 101
 102      PACKAGE BODY PACK1 IS
 103           FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
 104           BEGIN
 105                IF EQUAL(3,3) THEN
 106                     RETURN I;
 107                ELSE
 108                     RETURN PRIVY'(0);
 109                END IF;
 110           END IDENT;
 111
 112           FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
 113           BEGIN
 114                RETURN I+1;
 115           END NEXT;
 116      END PACK1;
 117
 118      PACKAGE BODY GENERIC1 IS
 119           XGI1 : INTEGER RENAMES GI1;
 120           XGA1 : ARRAY1 RENAMES GA1;
 121           XGR1 : RECORD1 RENAMES GR1;
 122           XGP1 : POINTER1 RENAMES GP1;
 123           XGV1 : PACK1.PRIVY RENAMES GV1;
 124           XGT1 : TASK1 RENAMES GT1;
 125
 126           TASK TYPE TASK2 IS
 127                ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
 128                              TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
 129                              TV1 : IN OUT PACK1.PRIVY;
 130                              TT1 : IN OUT TASK1);
 131           END TASK2;
 132
 133           G_CHK_TASK : TASK2;
 134
 135           GENERIC
 136                GGI1 : IN OUT INTEGER;
 137                GGA1 : IN OUT ARRAY1;
 138                GGR1 : IN OUT RECORD1;
 139                GGP1 : IN OUT POINTER1;
 140                GGV1 : IN OUT PACK1.PRIVY;
 141                GGT1 : IN OUT TASK1;
 142           PACKAGE GENERIC2 IS
 143           END GENERIC2;
 144
 145           PACKAGE BODY GENERIC2 IS
 146           BEGIN
 147                GGI1 := GGI1 + 1;
 148                GGA1 := (GGA1(1)+1, GGA1(2)+1, GGA1(3)+1);
 149                GGR1 := (D => 1, FIELD1 => GGR1.FIELD1 + 1);
 150                GGP1 := NEW INTEGER'(GGP1.ALL + 1);
 151                GGV1 := PACK1.NEXT(GGV1);
 152                GGT1.NEXT;
 153           END GENERIC2;
 154
 155           TASK BODY TASK2 IS
 156           BEGIN
 157                ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
 158                               TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
 159                               TV1 : IN OUT PACK1.PRIVY;
 160                               TT1 : IN OUT TASK1)
 161                DO
 162                     TI1 := GI1 + 1;
 163                     TA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
 164                     TR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
 165                     TP1 := NEW INTEGER'(TP1.ALL + 1);
 166                     TV1 := PACK1.NEXT(TV1);
 167                     TT1.NEXT;
 168                END ENTRY1;
 169           END TASK2;
 170
 171           PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1;
 172                            PR1 : IN OUT RECORD1; PP1 : OUT POINTER1;
 173                            PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS
 174           BEGIN
 175                PI1 := PI1 + 1;
 176                PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
 177                PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
 178                PP1 := NEW INTEGER'(GP1.ALL + 1);
 179                PV1 := PACK1.NEXT(GV1);
 180                PT1.NEXT;
 181           END PROC1;
 182
 183           PACKAGE GENPACK2 IS NEW GENERIC2
 184                (XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
 185
 186      BEGIN
 187           IF XGI1 /= IDENT_INT(1) THEN
 188                FAILED ("INCORRECT VALUE OF XGI1 (1)");
 189           END IF;
 190
 191           IF XGA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
 192                FAILED ("INCORRECT VALUE OF XGA1 (1)");
 193           END IF;
 194
 195           IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
 196                FAILED ("INCORRECT VALUE OF XGR1 (1)");
 197           END IF;
 198
 199           IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(1) THEN
 200                FAILED ("INCORRECT VALUE OF XGP1 (1)");
 201           END IF;
 202
 203           IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.ONE)) THEN
 204                FAILED ("INCORRECT VALUE OF XGV1 (1)");
 205           END IF;
 206
 207           XGT1.VALU(I);
 208           IF I /= IDENT_INT(1) THEN
 209                FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (1)");
 210           END IF;
 211
 212           PROC1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
 213
 214           IF XGI1 /= IDENT_INT(2) THEN
 215                FAILED ("INCORRECT VALUE OF XGI1 (2)");
 216           END IF;
 217
 218           IF XGA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
 219                FAILED ("INCORRECT VALUE OF XGA1 (2)");
 220           END IF;
 221
 222           IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
 223                FAILED ("INCORRECT VALUE OF XGR1 (2)");
 224           END IF;
 225
 226           IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(2) THEN
 227                FAILED ("INCORRECT VALUE OF XGP1 (2)");
 228           END IF;
 229
 230           IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.TWO)) THEN
 231                FAILED ("INCORRECT VALUE OF XGV1 (2)");
 232           END IF;
 233
 234           XGT1.VALU(I);
 235           IF I /= IDENT_INT(2) THEN
 236                FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (2)");
 237           END IF;
 238
 239           G_CHK_TASK.ENTRY1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
 240
 241           IF XGI1 /= IDENT_INT(3) THEN
 242                FAILED ("INCORRECT VALUE OF XGI1 (3)");
 243           END IF;
 244
 245           IF XGA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
 246                FAILED ("INCORRECT VALUE OF XGA1 (3)");
 247           END IF;
 248
 249           IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
 250                FAILED ("INCORRECT VALUE OF XGR1 (3)");
 251           END IF;
 252
 253           IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(3) THEN
 254                FAILED ("INCORRECT VALUE OF XGP1 (3)");
 255           END IF;
 256
 257           IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.THREE)) THEN
 258                FAILED ("INCORRECT VALUE OF XGV1 (3)");
 259           END IF;
 260
 261           XGT1.VALU(I);
 262           IF I /= IDENT_INT(3) THEN
 263                FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (3)");
 264           END IF;
 265
 266           XGI1 := XGI1 + 1;
 267           XGA1 := (XGA1(1)+1, XGA1(2)+1, XGA1(3)+1);
 268           XGR1 := (D => 1, FIELD1 => XGR1.FIELD1 + 1);
 269           XGP1 := NEW INTEGER'(XGP1.ALL + 1);
 270           XGV1 := PACK1.NEXT(XGV1);
 271           XGT1.NEXT;
 272
 273           IF XGI1 /= IDENT_INT(4) THEN
 274                FAILED ("INCORRECT VALUE OF XGI1 (4)");
 275           END IF;
 276
 277           IF XGA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
 278                FAILED ("INCORRECT VALUE OF XGA1 (4)");
 279           END IF;
 280
 281           IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
 282                FAILED ("INCORRECT VALUE OF XGR1 (4)");
 283           END IF;
 284
 285           IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(4) THEN
 286                FAILED ("INCORRECT VALUE OF XGP1 (4)");
 287           END IF;
 288
 289           IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FOUR)) THEN
 290                FAILED ("INCORRECT VALUE OF XGV1 (4)");
 291           END IF;
 292
 293           XGT1.VALU(I);
 294           IF I /= IDENT_INT(4) THEN
 295                FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (4)");
 296           END IF;
 297
 298           GI1 := GI1 + 1;
 299           GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
 300           GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
 301           GP1 := NEW INTEGER'(GP1.ALL + 1);
 302           GV1 := PACK1.NEXT(GV1);
 303           GT1.NEXT;
 304
 305           IF XGI1 /= IDENT_INT(5) THEN
 306                FAILED ("INCORRECT VALUE OF XGI1 (5)");
 307           END IF;
 308
 309           IF XGA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
 310                FAILED ("INCORRECT VALUE OF XGA1 (5)");
 311           END IF;
 312
 313           IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
 314                FAILED ("INCORRECT VALUE OF XGR1 (5)");
 315           END IF;
 316
 317           IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(5) THEN
 318                FAILED ("INCORRECT VALUE OF XGP1 (5)");
 319           END IF;
 320
 321           IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FIVE)) THEN
 322                FAILED ("INCORRECT VALUE OF XGV1 (5)");
 323           END IF;
 324
 325           XGT1.VALU(I);
 326           IF I /= IDENT_INT(5) THEN
 327                FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (5)");
 328           END IF;
 329      END GENERIC1;
 330
 331      TASK BODY TASK1 IS
 332           TASK_VALUE : INTEGER := 0;
 333           ACCEPTING_ENTRIES : BOOLEAN := TRUE;
 334      BEGIN
 335           WHILE ACCEPTING_ENTRIES LOOP
 336                SELECT
 337                     ACCEPT ASSIGN (J : IN INTEGER) DO
 338                          TASK_VALUE := J;
 339                     END ASSIGN;
 340                OR
 341                     ACCEPT VALU (J : OUT INTEGER) DO
 342                          J := TASK_VALUE;
 343                     END VALU;
 344                OR
 345                     ACCEPT NEXT DO
 346                          TASK_VALUE := TASK_VALUE + 1;
 347                     END NEXT;
 348                OR
 349                     ACCEPT STOP DO
 350                          ACCEPTING_ENTRIES := FALSE;
 351                     END STOP;
 352                END SELECT;
 353           END LOOP;
 354      END TASK1;
 355
 356 BEGIN
 357      TEST ("C85005D", "CHECK THAT A VARIABLE CREATED BY A GENERIC " &
 358                       "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " &
 359                       "AND HAS THE CORRECT VALUE, AND THAT THE NEW " &
 360                       "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " &
 361                       "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " &
 362                       "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " &
 363                       "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " &
 364                       "WHEN THE VALUE OF THE RENAMED VARIABLE IS " &
 365                       "CHANGED, THE NEW VALUE IS REFLECTED BY THE " &
 366                       "VALUE OF THE NEW NAME");
 367
 368      DECLARE
 369           PACKAGE GENPACK1 IS NEW
 370                GENERIC1 (DI1, DA1, DR1, DP1, DV1, DT1);
 371      BEGIN
 372           NULL;
 373      END;
 374
 375      DT1.STOP;
 376
 377      RESULT;
 378 END C85005D;