old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c38002a.ada

   1 -- C38002A.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 AN UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT
  27 --     DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION
  28 --     WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT.
  29 --
  30 --     CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN
  31 --     SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT
  32 --     DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT
  33 --     DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION,
  34 --     DERIVED TYPE DEFINITION, PRIVATE TYPE.
  35 --
  36 --     CHECK FOR UNCONSTRAINED GENERIC FORMAL TYPE.
  37
  38 -- HISTORY:
  39 --     AH  09/02/86 CREATED ORIGINAL TEST.
  40 --     DHH 08/16/88 REVISED HEADER AND ENTERED COMMENTS FOR PRIVATE TYPE
  41 --                  AND CORRECTED INDENTATION.
  42 --     BCB 04/12/90 ADDED CHECKS FOR AN ARRAY AS A SUBPROGRAM RETURN
  43 --                  TYPE AND AN ARRAY AS A FORMAL PARAMETER.
  44 --     LDC 10/01/90 ADDED CODE SO F, FPROC, G, GPROC AREN'T OPTIMIZED
  45 --                  AWAY
  46
  47 WITH REPORT; USE REPORT;
  48 PROCEDURE C38002A IS
  49
  50 BEGIN
  51      TEST ("C38002A", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " &
  52            "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " &
  53            "ARRAY OR RECORD TYPES");
  54
  55      DECLARE
  56           C3 : CONSTANT INTEGER := IDENT_INT(3);
  57
  58           TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
  59           TYPE ARR_NAME IS ACCESS ARR;
  60           SUBTYPE ARR_NAME_3 IS ARR_NAME(1..3);
  61
  62           TYPE REC(DISC : INTEGER) IS
  63                RECORD
  64                     COMP : ARR_NAME(1..DISC);
  65                END RECORD;
  66           TYPE REC_NAME IS ACCESS REC;
  67
  68           OBJ : REC_NAME(C3);
  69
  70           TYPE ARR2 IS ARRAY (1..10) OF REC_NAME(C3);
  71
  72           TYPE REC2 IS
  73                RECORD
  74                     COMP2 : REC_NAME(C3);
  75                END RECORD;
  76
  77           TYPE NAME_REC_NAME IS ACCESS REC_NAME(C3);
  78
  79           TYPE DERIV IS NEW REC_NAME(C3);
  80           SUBTYPE REC_NAME_3 IS REC_NAME(C3);
  81
  82           FUNCTION F (PARM : REC_NAME_3) RETURN REC_NAME_3 IS
  83           BEGIN
  84                IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
  85                     COMMENT("DON'T OPTIMIZE F AWAY");
  86                END IF;
  87                RETURN PARM;
  88           END;
  89
  90           PROCEDURE FPROC (PARM : REC_NAME_3) IS
  91           BEGIN
  92                IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
  93                     COMMENT("DON'T OPTIMIZE FPROC AWAY");
  94                END IF;
  95           END FPROC;
  96
  97           FUNCTION G (PA : ARR_NAME_3) RETURN ARR_NAME_3 IS
  98           BEGIN
  99                IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN
 100                     COMMENT("DON'T OPTIMIZE G AWAY");
 101                END IF;
 102                RETURN PA;
 103           END G;
 104
 105           PROCEDURE GPROC (PA : ARR_NAME_3) IS
 106           BEGIN
 107                IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN
 108                     COMMENT("DON'T OPTIMIZE GPROC AWAY");
 109                END IF;
 110           END GPROC;
 111
 112      BEGIN
 113           DECLARE
 114                R : REC_NAME;
 115           BEGIN
 116                R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));
 117                R := F(R);
 118                R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));
 119                R := F(R);
 120                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 121                        "ACCEPTED BY FUNCTION FOR RECORD");
 122           EXCEPTION
 123                WHEN CONSTRAINT_ERROR =>
 124                     IF R = NULL OR ELSE R.DISC /= 4 THEN
 125                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
 126                                  "ACCESS VALUE - RECORD,FUNCTION");
 127                     END IF;
 128           END;
 129
 130           DECLARE
 131                R : REC_NAME;
 132           BEGIN
 133                R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));
 134                FPROC(R);
 135                R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));
 136                FPROC(R);
 137                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 138                        "ACCEPTED BY PROCEDURE FOR RECORD");
 139           EXCEPTION
 140                WHEN CONSTRAINT_ERROR =>
 141                     IF R = NULL OR ELSE R.DISC /= 4 THEN
 142                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
 143                                  "ACCESS VALUE - RECORD,PROCEDURE");
 144                     END IF;
 145           END;
 146
 147           DECLARE
 148                A : ARR_NAME;
 149           BEGIN
 150                A := NEW ARR'(1..3 => 5);
 151                A := G(A);
 152                A := NEW ARR'(1..4 => 6);
 153                A := G(A);
 154                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 155                        "ACCEPTED BY FUNCTION FOR ARRAY");
 156           EXCEPTION
 157                WHEN CONSTRAINT_ERROR =>
 158                     IF A = NULL OR ELSE A(4) /= 6 THEN
 159                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
 160                                  "ACCESS VALUE - ARRAY,FUNCTION");
 161                     END IF;
 162           END;
 163
 164           DECLARE
 165                A : ARR_NAME;
 166           BEGIN
 167                A := NEW ARR'(1..3 => 5);
 168                GPROC(A);
 169                A := NEW ARR'(1..4 => 6);
 170                GPROC(A);
 171                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 172                        "ACCEPTED BY PROCEDURE FOR ARRAY");
 173           EXCEPTION
 174                WHEN CONSTRAINT_ERROR =>
 175                     IF A = NULL OR ELSE A(4) /= 6 THEN
 176                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
 177                                  "ACCESS VALUE - ARRAY,PROCEDURE");
 178                     END IF;
 179           END;
 180      END;
 181
 182      DECLARE
 183           C3 : CONSTANT INTEGER := IDENT_INT(3);
 184
 185           TYPE REC (DISC : INTEGER) IS
 186                RECORD
 187                     NULL;
 188                END RECORD;
 189
 190           TYPE P_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
 191           TYPE P_ARR_NAME IS ACCESS P_ARR;
 192
 193           TYPE P_REC_NAME IS ACCESS REC;
 194
 195           GENERIC
 196                TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
 197           PACKAGE P IS
 198                TYPE ACC_REC IS ACCESS REC;
 199                TYPE ACC_ARR IS ACCESS UNCON_ARR;
 200                TYPE ACC_P_ARR IS ACCESS P_ARR;
 201                SUBTYPE ACC_P_ARR_3 IS ACC_P_ARR(1..3);
 202                OBJ : ACC_REC(C3);
 203
 204                TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3);
 205
 206                TYPE REC1 IS
 207                     RECORD
 208                          COMP1 : ACC_REC(C3);
 209                     END RECORD;
 210
 211                TYPE REC2 IS
 212                     RECORD
 213                          COMP2 : ACC_ARR(1..C3);
 214                     END RECORD;
 215
 216                SUBTYPE ACC_REC_3 IS ACC_REC(C3);
 217
 218                FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3;
 219
 220                PROCEDURE FPROC (PARM : ACC_REC_3);
 221
 222                FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3;
 223
 224                PROCEDURE GPROC (PA : ACC_P_ARR_3);
 225
 226                TYPE ACC1 IS PRIVATE;
 227                TYPE ACC2 IS PRIVATE;
 228                TYPE DER1 IS PRIVATE;
 229                TYPE DER2 IS PRIVATE;
 230
 231           PRIVATE
 232
 233                TYPE ACC1 IS ACCESS ACC_REC(C3);
 234                TYPE ACC2 IS ACCESS ACC_ARR(1..C3);
 235                TYPE DER1 IS NEW ACC_REC(C3);
 236                TYPE DER2 IS NEW ACC_ARR(1..C3);
 237           END P;
 238
 239           PACKAGE BODY P IS
 240                FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS
 241                BEGIN
 242                     IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
 243                          COMMENT("DON'T OPTIMIZE F AWAY");
 244                     END IF;
 245                     RETURN PARM;
 246                END;
 247
 248                PROCEDURE FPROC (PARM : ACC_REC_3) IS
 249                BEGIN
 250                     IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
 251                          COMMENT("DON'T OPTIMIZE FPROC AWAY");
 252                     END IF;
 253                END FPROC;
 254
 255                FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3 IS
 256                BEGIN
 257                     IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN
 258                          COMMENT("DON'T OPTIMIZE G AWAY");
 259                     END IF;
 260                     RETURN PA;
 261                END;
 262
 263                PROCEDURE GPROC (PA : ACC_P_ARR_3) IS
 264                BEGIN
 265                     IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN
 266                          COMMENT("DON'T OPTIMIZE GPROC AWAY");
 267                     END IF;
 268                END GPROC;
 269           END P;
 270
 271           PACKAGE NP IS NEW P (UNCON_ARR => P_ARR);
 272
 273           USE NP;
 274
 275      BEGIN
 276           DECLARE
 277                R : ACC_REC;
 278           BEGIN
 279                R := NEW REC(DISC => 3);
 280                R := F(R);
 281                R := NEW REC(DISC => 4);
 282                R := F(R);
 283                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 284                        "ACCEPTED BY FUNCTION FOR A RECORD -GENERIC");
 285           EXCEPTION
 286                WHEN CONSTRAINT_ERROR =>
 287                     IF R = NULL OR ELSE R.DISC /= 4 THEN
 288                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
 289                                  "OF ACCESS VALUE - RECORD," &
 290                                  "FUNCTION -GENERIC");
 291                     END IF;
 292           END;
 293
 294           DECLARE
 295                R : ACC_REC;
 296           BEGIN
 297                R := NEW REC(DISC => 3);
 298                FPROC(R);
 299                R := NEW REC(DISC => 4);
 300                FPROC(R);
 301                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 302                        "ACCEPTED BY PROCEDURE FOR A RECORD -GENERIC");
 303           EXCEPTION
 304                WHEN CONSTRAINT_ERROR =>
 305                     IF R = NULL OR ELSE R.DISC /= 4 THEN
 306                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
 307                                  "OF ACCESS VALUE - RECORD," &
 308                                  "PROCEDURE -GENERIC");
 309                     END IF;
 310           END;
 311
 312           DECLARE
 313                A : ACC_P_ARR;
 314           BEGIN
 315                A := NEW P_ARR'(1..3 => 5);
 316                A := G(A);
 317                A := NEW P_ARR'(1..4 => 6);
 318                A := G(A);
 319                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 320                        "ACCEPTED BY FUNCTION FOR AN ARRAY -GENERIC");
 321           EXCEPTION
 322                WHEN CONSTRAINT_ERROR =>
 323                     IF A = NULL OR ELSE A(4) /= 6 THEN
 324                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
 325                                  "OF ACCESS VALUE - ARRAY," &
 326                                  "FUNCTION -GENERIC");
 327                     END IF;
 328           END;
 329
 330           DECLARE
 331                A : ACC_P_ARR;
 332           BEGIN
 333                A := NEW P_ARR'(1..3 => 5);
 334                GPROC(A);
 335                A := NEW P_ARR'(1..4 => 6);
 336                GPROC(A);
 337                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 338                        "ACCEPTED BY PROCEDURE FOR AN ARRAY -GENERIC");
 339           EXCEPTION
 340                WHEN CONSTRAINT_ERROR =>
 341                     IF A = NULL OR ELSE A(4) /= 6 THEN
 342                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
 343                                  "OF ACCESS VALUE - ARRAY," &
 344                                  "PROCEDURE -GENERIC");
 345                     END IF;
 346           END;
 347      END;
 348
 349      DECLARE
 350           TYPE CON_INT IS RANGE 1..10;
 351
 352           GENERIC
 353                TYPE UNCON_INT IS RANGE <>;
 354           PACKAGE P2 IS
 355                SUBTYPE NEW_INT IS UNCON_INT RANGE 1..5;
 356                FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT;
 357
 358                PROCEDURE PROC_INT (PARM : NEW_INT);
 359           END P2;
 360
 361           PACKAGE BODY P2 IS
 362                FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT IS
 363                BEGIN
 364                     IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
 365                          COMMENT("DON'T OPTIMIZE F AWAY");
 366                     END IF;
 367                     RETURN PARM;
 368                END FUNC_INT;
 369
 370                PROCEDURE PROC_INT (PARM : NEW_INT) IS
 371                BEGIN
 372                     IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
 373                          COMMENT("DON'T OPTIMIZE FPROC AWAY");
 374                     END IF;
 375                END PROC_INT;
 376           END P2;
 377
 378           PACKAGE NP2 IS NEW P2 (UNCON_INT => CON_INT);
 379
 380           USE NP2;
 381
 382      BEGIN
 383           DECLARE
 384                R : CON_INT;
 385           BEGIN
 386                R := 2;
 387                R := FUNC_INT(R);
 388                R := 8;
 389                R := FUNC_INT(R);
 390                FAILED ("INCOMPATIBLE CONSTRAINT ON VALUE " &
 391                        "ACCEPTED BY FUNCTION -GENERIC");
 392           EXCEPTION
 393                WHEN CONSTRAINT_ERROR =>
 394                     IF R /= 8 THEN
 395                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
 396                                  "OF VALUE -FUNCTION, GENERIC");
 397                     END IF;
 398           END;
 399
 400           DECLARE
 401                R : CON_INT;
 402           BEGIN
 403                R := 2;
 404                PROC_INT(R);
 405                R := 9;
 406                PROC_INT(R);
 407                FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
 408                        "ACCEPTED BY PROCEDURE -GENERIC");
 409           EXCEPTION
 410                WHEN CONSTRAINT_ERROR =>
 411                     IF R /= 9 THEN
 412                          FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
 413                                  "OF ACCESS VALUE - PROCEDURE, " &
 414                                  "GENERIC");
 415                     END IF;
 416           END;
 417      END;
 418
 419      RESULT;
 420 END C38002A;