old-autovect-branch/gcc/testsuite/ada/acats/tests/c7/c74302b.ada

   1 -- C74302B.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 WHEN THE FULL DECLARATION OF A DEFERRED CONSTANT IS
  27 --     GIVEN AS A MULTIPLE DECLARATION, THE INITIALIZATION EXPRESSION
  28 --     IS EVALUATED ONCE FOR EACH DEFERRED CONSTANT.  (USE ENUMERATION,
  29 --     INTEGER, FIXED POINT, FLOATING POINT, ARRAY, RECORD (INCLUDING
  30 --     USE OF DEFAULT EXPRESSIONS FOR COMPONENTS), ACCESS, AND PRIVATE
  31 --     TYPES AS FULL DECLARATION OF PRIVATE TYPE)
  32
  33 -- HISTORY:
  34 --     BCB 07/25/88  CREATED ORIGINAL TEST.
  35
  36 WITH REPORT; USE REPORT;
  37
  38 PROCEDURE C74302B IS
  39
  40      TYPE ARR_RAN IS RANGE 1..2;
  41
  42      BUMP : INTEGER := IDENT_INT(0);
  43
  44      GENERIC
  45           TYPE DT IS (<>);
  46      FUNCTION F1 RETURN DT;
  47
  48      GENERIC
  49           TYPE FE IS DELTA <>;
  50      FUNCTION F2 RETURN FE;
  51
  52      GENERIC
  53           TYPE FLE IS DIGITS <>;
  54      FUNCTION F3 RETURN FLE;
  55
  56      GENERIC
  57           TYPE CA IS ARRAY(ARR_RAN) OF INTEGER;
  58      FUNCTION F4 RETURN CA;
  59
  60      GENERIC
  61           TYPE GP IS LIMITED PRIVATE;
  62      FUNCTION F5 (V : GP) RETURN GP;
  63
  64      GENERIC
  65           TYPE GP1 IS LIMITED PRIVATE;
  66      FUNCTION F6 (V1 : GP1) RETURN GP1;
  67
  68      GENERIC
  69           TYPE AC IS ACCESS INTEGER;
  70      FUNCTION F7 RETURN AC;
  71
  72      GENERIC
  73           TYPE PP IS PRIVATE;
  74      FUNCTION F8 (P1 : PP) RETURN PP;
  75
  76      FUNCTION F1 RETURN DT IS
  77      BEGIN
  78           BUMP := BUMP + 1;
  79           RETURN DT'VAL(BUMP);
  80      END F1;
  81
  82      FUNCTION F2 RETURN FE IS
  83      BEGIN
  84           BUMP := BUMP + 1;
  85           RETURN FE(BUMP);
  86      END F2;
  87
  88      FUNCTION F3 RETURN FLE IS
  89      BEGIN
  90           BUMP := BUMP + 1;
  91           RETURN FLE(BUMP);
  92      END F3;
  93
  94      FUNCTION F4 RETURN CA IS
  95      BEGIN
  96           BUMP := BUMP + 1;
  97           RETURN ((BUMP,BUMP-1));
  98      END F4;
  99
 100      FUNCTION F5 (V : GP) RETURN GP IS
 101      BEGIN
 102           BUMP := BUMP + 1;
 103           RETURN V;
 104      END F5;
 105
 106      FUNCTION F6 (V1 : GP1) RETURN GP1 IS
 107      BEGIN
 108           BUMP := BUMP + 1;
 109           RETURN V1;
 110      END F6;
 111
 112      FUNCTION F7 RETURN AC IS
 113           VAR : AC;
 114      BEGIN
 115           BUMP := BUMP + 1;
 116           VAR := NEW INTEGER'(BUMP);
 117           RETURN VAR;
 118      END F7;
 119
 120      FUNCTION F8 (P1 : PP) RETURN PP IS
 121      BEGIN
 122           BUMP := BUMP + 1;
 123           RETURN P1;
 124      END F8;
 125
 126      PACKAGE PACK IS
 127           TYPE SP IS PRIVATE;
 128           CONS : CONSTANT SP;
 129      PRIVATE
 130           TYPE SP IS RANGE 1 .. 100;
 131           CONS : CONSTANT SP := 50;
 132      END PACK;
 133
 134      USE PACK;
 135
 136      PACKAGE P IS
 137           TYPE INT IS PRIVATE;
 138           TYPE ENUM IS PRIVATE;
 139           TYPE FIX IS PRIVATE;
 140           TYPE FLT IS PRIVATE;
 141           TYPE CON_ARR IS PRIVATE;
 142           TYPE REC IS PRIVATE;
 143           TYPE REC1 IS PRIVATE;
 144           TYPE ACC IS PRIVATE;
 145           TYPE PRIV IS PRIVATE;
 146
 147           GENERIC
 148                TYPE LP IS PRIVATE;
 149           FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN;
 150
 151           I1, I2, I3, I4 : CONSTANT INT;
 152           E1, E2, E3, E4 : CONSTANT ENUM;
 153           FI1, FI2, FI3, FI4 : CONSTANT FIX;
 154           FL1, FL2, FL3, FL4 : CONSTANT FLT;
 155           CA1, CA2, CA3, CA4 : CONSTANT CON_ARR;
 156           R1, R2, R3, R4 : CONSTANT REC;
 157           R1A, R2A, R3A, R4A : CONSTANT REC1;
 158           A1, A2, A3, A4 : CONSTANT ACC;
 159           PR1, PR2, PR3, PR4 : CONSTANT PRIV;
 160      PRIVATE
 161           TYPE INT IS RANGE 1 .. 100;
 162
 163           TYPE ENUM IS (ONE,TWO,THREE,FOUR,FIVE,SIX,SEVEN,EIGHT,NINE);
 164
 165           TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0;
 166
 167           TYPE FLT IS DIGITS 5 RANGE -100.0 .. 100.0;
 168
 169           TYPE CON_ARR IS ARRAY(ARR_RAN) OF INTEGER;
 170
 171           TYPE REC IS RECORD
 172                COMP1 : INTEGER;
 173                COMP2 : INTEGER;
 174                COMP3 : BOOLEAN;
 175           END RECORD;
 176
 177           TYPE REC1 IS RECORD
 178                COMP1 : INTEGER := 10;
 179                COMP2 : INTEGER := 20;
 180                COMP3 : BOOLEAN := FALSE;
 181           END RECORD;
 182
 183           TYPE ACC IS ACCESS INTEGER;
 184
 185           TYPE PRIV IS NEW SP;
 186
 187           FUNCTION DDT IS NEW F1 (INT);
 188           FUNCTION EDT IS NEW F1 (ENUM);
 189           FUNCTION FDT IS NEW F2 (FIX);
 190           FUNCTION FLDT IS NEW F3 (FLT);
 191           FUNCTION CADT IS NEW F4 (CON_ARR);
 192           FUNCTION RDT IS NEW F5 (REC);
 193           FUNCTION R1DT IS NEW F6 (REC1);
 194           FUNCTION ADT IS NEW F7 (ACC);
 195           FUNCTION PDT IS NEW F8 (PRIV);
 196
 197           REC_OBJ : REC := (1,2,TRUE);
 198           REC1_OBJ : REC1 := (3,4,FALSE);
 199
 200           I1, I2, I3, I4 : CONSTANT INT := DDT;
 201           E1, E2, E3, E4 : CONSTANT ENUM := EDT;
 202           FI1, FI2, FI3, FI4 : CONSTANT FIX := FDT;
 203           FL1, FL2, FL3, FL4 : CONSTANT FLT := FLDT;
 204           CA1, CA2, CA3, CA4 : CONSTANT CON_ARR := CADT;
 205           R1, R2, R3, R4 : CONSTANT REC := RDT(REC_OBJ);
 206           R1A, R2A, R3A, R4A : CONSTANT REC1 := R1DT(REC1_OBJ);
 207           A1, A2, A3, A4 : CONSTANT ACC := ADT;
 208           PR1, PR2, PR3, PR4 : CONSTANT PRIV := PDT(PRIV(CONS));
 209      END P;
 210
 211      PACKAGE BODY P IS
 212           AVAR1 : ACC := NEW INTEGER'(29);
 213           AVAR2 : ACC := NEW INTEGER'(30);
 214           AVAR3 : ACC := NEW INTEGER'(31);
 215           AVAR4 : ACC := NEW INTEGER'(32);
 216
 217           FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN IS
 218           BEGIN
 219                RETURN Z1 = Z2;
 220           END GEN_EQUAL;
 221
 222           FUNCTION INT_EQUAL IS NEW GEN_EQUAL (INT);
 223           FUNCTION ENUM_EQUAL IS NEW GEN_EQUAL (ENUM);
 224           FUNCTION FIX_EQUAL IS NEW GEN_EQUAL (FIX);
 225           FUNCTION FLT_EQUAL IS NEW GEN_EQUAL (FLT);
 226           FUNCTION ARR_EQUAL IS NEW GEN_EQUAL (CON_ARR);
 227           FUNCTION REC_EQUAL IS NEW GEN_EQUAL (REC);
 228           FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1);
 229           FUNCTION ACC_EQUAL IS NEW GEN_EQUAL (INTEGER);
 230           FUNCTION PRIV_EQUAL IS NEW GEN_EQUAL (PRIV);
 231      BEGIN
 232           TEST ("C74302B", "CHECK THAT WHEN THE FULL DECLARATION OF " &
 233                            "A DEFERRED CONSTANT IS GIVEN AS A " &
 234                            "MULTIPLE DECLARATION, THE INITIALIZATION " &
 235                            "EXPRESSION IS EVALUATED ONCE FOR EACH " &
 236                            "DEFERRED CONSTANT");
 237
 238           IF NOT EQUAL(BUMP,36) THEN
 239                FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 240                        "DEFERRED CONSTANTS IN A MULIPLE DECLARATION");
 241           END IF;
 242
 243           IF NOT INT_EQUAL(I1,1) OR NOT INT_EQUAL(I2,2) OR
 244              NOT INT_EQUAL(I3,3) OR NOT INT_EQUAL(I4,4) THEN
 245                FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 246                        "DEFERRED INTEGER CONSTANTS");
 247           END IF;
 248
 249           IF NOT ENUM_EQUAL(E1,SIX) OR NOT ENUM_EQUAL(E2,SEVEN) OR
 250              NOT ENUM_EQUAL(E3,EIGHT) OR NOT ENUM_EQUAL(E4,NINE) THEN
 251                FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 252                        "DEFERRED ENUMERATION CONSTANTS");
 253           END IF;
 254
 255           IF NOT FIX_EQUAL(FI1,9.0) OR NOT FIX_EQUAL(FI2,10.0) OR
 256              NOT FIX_EQUAL(FI3,11.0) OR NOT FIX_EQUAL(FI4,12.0) THEN
 257                FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 258                        "DEFERRED FIXED POINT CONSTANTS");
 259           END IF;
 260
 261           IF NOT FLT_EQUAL(FL1,13.0) OR NOT FLT_EQUAL(FL2,14.0) OR
 262              NOT FLT_EQUAL(FL3,15.0) OR NOT FLT_EQUAL(FL4,16.0) THEN
 263                FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 264                        "DEFERRED FLOATING POINT CONSTANTS");
 265           END IF;
 266
 267           IF NOT ARR_EQUAL(CA1,(17,16)) OR NOT ARR_EQUAL(CA2,(18,17))
 268            OR NOT ARR_EQUAL(CA3,(19,18)) OR NOT ARR_EQUAL(CA4,(20,19))
 269                THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 270                             "DEFERRED ARRAY CONSTANTS");
 271           END IF;
 272
 273           IF NOT REC_EQUAL(R1,REC_OBJ) OR NOT REC_EQUAL(R2,REC_OBJ)
 274              OR NOT REC_EQUAL(R3,REC_OBJ) OR NOT REC_EQUAL(R4,REC_OBJ)
 275                THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 276                             "DEFERRED RECORD CONSTANTS");
 277           END IF;
 278
 279           IF NOT REC1_EQUAL(R1A,REC1_OBJ) OR NOT REC1_EQUAL(R2A,
 280              REC1_OBJ) OR NOT REC1_EQUAL(R3A,REC1_OBJ) OR NOT
 281              REC1_EQUAL(R4A,REC1_OBJ) THEN
 282                FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 283                        "DEFERRED RECORD CONSTANTS WITH DEFAULT " &
 284                        "EXPRESSIONS");
 285           END IF;
 286
 287           IF NOT ACC_EQUAL(A1.ALL,AVAR1.ALL) OR NOT ACC_EQUAL(A2.ALL,
 288              AVAR2.ALL) OR NOT ACC_EQUAL(A3.ALL,AVAR3.ALL) OR NOT
 289              ACC_EQUAL(A4.ALL,AVAR4.ALL) THEN
 290                FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 291                        "DEFERRED ACCESS CONSTANTS");
 292           END IF;
 293
 294           IF NOT PRIV_EQUAL(PR1,PRIV(CONS)) OR NOT PRIV_EQUAL(PR2,
 295              PRIV(CONS)) OR NOT PRIV_EQUAL(PR3,PRIV(CONS)) OR NOT
 296              PRIV_EQUAL(PR4,PRIV(CONS)) THEN
 297                FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
 298                        "DEFERRED PRIVATE CONSTANTS");
 299           END IF;
 300
 301           RESULT;
 302      END P;
 303
 304      USE P;
 305
 306 BEGIN
 307      NULL;
 308 END C74302B;