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

   1 -- C85005B.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 SUBPROGRAM 'IN OUT' FORMAL
  27 --     PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND THAT
  28 --     THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND PASSED
  29 --     ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER,
  30 --     AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE
  31 --     VALUE OF THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS
  32 --     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 C85005B 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      BEGIN
 120           GI1 := GI1 + 1;
 121           GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
 122           GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
 123           GP1 := NEW INTEGER'(GP1.ALL + 1);
 124           GV1 := PACK1.NEXT(GV1);
 125           GT1.NEXT;
 126      END GENERIC1;
 127
 128      TASK BODY TASK1 IS
 129           TASK_VALUE : INTEGER := 0;
 130           ACCEPTING_ENTRIES : BOOLEAN := TRUE;
 131      BEGIN
 132           WHILE ACCEPTING_ENTRIES LOOP
 133                SELECT
 134                     ACCEPT ASSIGN (J : IN INTEGER) DO
 135                          TASK_VALUE := J;
 136                     END ASSIGN;
 137                OR
 138                     ACCEPT VALU (J : OUT INTEGER) DO
 139                          J := TASK_VALUE;
 140                     END VALU;
 141                OR
 142                     ACCEPT NEXT DO
 143                          TASK_VALUE := TASK_VALUE + 1;
 144                     END NEXT;
 145                OR
 146                     ACCEPT STOP DO
 147                          ACCEPTING_ENTRIES := FALSE;
 148                     END STOP;
 149                END SELECT;
 150           END LOOP;
 151      END TASK1;
 152
 153      PROCEDURE PROC (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1;
 154                      PR1 : IN OUT RECORD1; PP1 : IN OUT POINTER1;
 155                      PV1 : IN OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS
 156           XPI1 : INTEGER RENAMES PI1;
 157           XPA1 : ARRAY1 RENAMES PA1;
 158           XPR1 : RECORD1 RENAMES PR1;
 159           XPP1 : POINTER1 RENAMES PP1;
 160           XPV1 : PACK1.PRIVY RENAMES PV1;
 161           XPT1 : TASK1 RENAMES PT1;
 162
 163           TASK TYPE TASK2 IS
 164                ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
 165                              TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
 166                              TV1 : IN OUT PACK1.PRIVY;
 167                              TT1 : IN OUT TASK1);
 168           END TASK2;
 169
 170           CHK_TASK : TASK2;
 171
 172           PROCEDURE PROC1 (PPI1 : IN OUT INTEGER; PPA1 : IN OUT ARRAY1;
 173                            PPR1 : IN OUT RECORD1; PPP1 : OUT POINTER1;
 174                            PPV1 : OUT PACK1.PRIVY;
 175                            PPT1 : IN OUT TASK1) IS
 176           BEGIN
 177                PPI1 := PPI1 + 1;
 178                PPA1 := (PPA1(1)+1, PPA1(2)+1, PPA1(3)+1);
 179                PPR1 := (D => 1, FIELD1 => PPR1.FIELD1 + 1);
 180                PPP1 := NEW INTEGER'(PP1.ALL + 1);
 181                PPV1 := PACK1.NEXT(PV1);
 182                PPT1.NEXT;
 183           END PROC1;
 184
 185           TASK BODY TASK2 IS
 186           BEGIN
 187                ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
 188                               TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
 189                               TV1 : IN OUT PACK1.PRIVY;
 190                               TT1 : IN OUT TASK1)
 191                DO
 192                     TI1 := PI1 + 1;
 193                     TA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
 194                     TR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
 195                     TP1 := NEW INTEGER'(TP1.ALL + 1);
 196                     TV1 := PACK1.NEXT(TV1);
 197                     TT1.NEXT;
 198                END ENTRY1;
 199           END TASK2;
 200
 201           PACKAGE GENPACK1 IS NEW GENERIC1
 202                (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1);
 203
 204      BEGIN
 205           IF XPI1 /= IDENT_INT(1) THEN
 206                FAILED ("INCORRECT VALUE OF XPI1 (1)");
 207           END IF;
 208
 209           IF XPA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
 210                FAILED ("INCORRECT VALUE OF XPA1 (1)");
 211           END IF;
 212
 213           IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
 214                FAILED ("INCORRECT VALUE OF XPR1 (1)");
 215           END IF;
 216
 217           IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(1) THEN
 218                FAILED ("INCORRECT VALUE OF XPP1 (1)");
 219           END IF;
 220
 221           IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.ONE)) THEN
 222                FAILED ("INCORRECT VALUE OF XPV1 (1)");
 223           END IF;
 224
 225           XPT1.VALU(I);
 226           IF I /= IDENT_INT(1) THEN
 227                FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (1)");
 228           END IF;
 229
 230           PROC1(XPI1, XPA1, XPR1, XPP1, XPV1, XPT1);
 231
 232           IF XPI1 /= IDENT_INT(2) THEN
 233                FAILED ("INCORRECT VALUE OF XPI1 (2)");
 234           END IF;
 235
 236           IF XPA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
 237                FAILED ("INCORRECT VALUE OF XPA1 (2)");
 238           END IF;
 239
 240           IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
 241                FAILED ("INCORRECT VALUE OF XPR1 (2)");
 242           END IF;
 243
 244           IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(2) THEN
 245                FAILED ("INCORRECT VALUE OF XPP1 (2)");
 246           END IF;
 247
 248           IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.TWO)) THEN
 249                FAILED ("INCORRECT VALUE OF XPV1 (2)");
 250           END IF;
 251
 252           XPT1.VALU(I);
 253           IF I /= IDENT_INT(2) THEN
 254                FAILED ("INCORRECT RETURN VALUE FROM XPT1.VALU (2)");
 255           END IF;
 256
 257           CHK_TASK.ENTRY1 (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1);
 258
 259           IF XPI1 /= IDENT_INT(3) THEN
 260                FAILED ("INCORRECT VALUE OF XPI1 (3)");
 261           END IF;
 262
 263           IF XPA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
 264                FAILED ("INCORRECT VALUE OF XPA1 (3)");
 265           END IF;
 266
 267           IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
 268                FAILED ("INCORRECT VALUE OF XPR1 (3)");
 269           END IF;
 270
 271           IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(3) THEN
 272                FAILED ("INCORRECT VALUE OF XPP1 (3)");
 273           END IF;
 274
 275           IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.THREE)) THEN
 276                FAILED ("INCORRECT VALUE OF XPV1 (3)");
 277           END IF;
 278
 279           XPT1.VALU(I);
 280           IF I /= IDENT_INT(3) THEN
 281                FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (3)");
 282           END IF;
 283
 284           XPI1 := XPI1 + 1;
 285           XPA1 := (XPA1(1)+1, XPA1(2)+1, XPA1(3)+1);
 286           XPR1 := (D => 1, FIELD1 => XPR1.FIELD1 + 1);
 287           XPP1 := NEW INTEGER'(XPP1.ALL + 1);
 288           XPV1 := PACK1.NEXT(XPV1);
 289           XPT1.NEXT;
 290
 291           IF XPI1 /= IDENT_INT(4) THEN
 292                FAILED ("INCORRECT VALUE OF XPI1 (4)");
 293           END IF;
 294
 295           IF XPA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
 296                FAILED ("INCORRECT VALUE OF XPA1 (4)");
 297           END IF;
 298
 299           IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
 300                FAILED ("INCORRECT VALUE OF XPR1 (4)");
 301           END IF;
 302
 303           IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(4) THEN
 304                FAILED ("INCORRECT VALUE OF XPP1 (4)");
 305           END IF;
 306
 307           IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FOUR)) THEN
 308                FAILED ("INCORRECT VALUE OF XPV1 (4)");
 309           END IF;
 310
 311           XPT1.VALU(I);
 312           IF I /= IDENT_INT(4) THEN
 313                FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (4)");
 314           END IF;
 315
 316           PI1 := PI1 + 1;
 317           PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
 318           PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
 319           PP1 := NEW INTEGER'(PP1.ALL + 1);
 320           PV1 := PACK1.NEXT(PV1);
 321           PT1.NEXT;
 322
 323           IF XPI1 /= IDENT_INT(5) THEN
 324                FAILED ("INCORRECT VALUE OF XPI1 (5)");
 325           END IF;
 326
 327           IF XPA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
 328                FAILED ("INCORRECT VALUE OF XPA1 (5)");
 329           END IF;
 330
 331           IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
 332                FAILED ("INCORRECT VALUE OF XPR1 (5)");
 333           END IF;
 334
 335           IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(5) THEN
 336                FAILED ("INCORRECT VALUE OF XPP1 (5)");
 337           END IF;
 338
 339           IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FIVE)) THEN
 340                FAILED ("INCORRECT VALUE OF XPV1 (5)");
 341           END IF;
 342
 343           XPT1.VALU(I);
 344           IF I /= IDENT_INT(5) THEN
 345                FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (5)");
 346           END IF;
 347      END PROC;
 348
 349 BEGIN
 350      TEST ("C85005B", "CHECK THAT A VARIABLE CREATED BY A SUBPROGRAM " &
 351                       "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " &
 352                       "AND HAS THE CORRECT VALUE, AND THAT THE NEW " &
 353                       "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " &
 354                       "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " &
 355                       "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " &
 356                       "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " &
 357                       "WHEN THE VALUE OF THE RENAMED VARIABLE IS " &
 358                       "CHANGED, THE NEW VALUE IS REFLECTED BY THE " &
 359                       "VALUE OF THE NEW NAME");
 360
 361      PROC (DI1, DA1, DR1, DP1, DV1, DT1);
 362
 363      DT1.STOP;
 364
 365      RESULT;
 366 END C85005B;