gcc/testsuite/ada/acats/tests/c8/c85005a.ada

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