old-autovect-branch/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada

   1 -- CC3123A.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 -- CHECK THAT DEFAULT EXPRESSIONS FOR GENERIC IN PARAMETERS ARE ONLY
  26 -- EVALUATED IF THERE ARE NO ACTUAL PARAMETERS.
  27
  28 -- TBN  12/01/86
  29
  30 WITH REPORT; USE REPORT;
  31 PROCEDURE CC3123A IS
  32
  33 BEGIN
  34      TEST ("CC3123A", "CHECK THAT DEFAULT EXPRESSIONS FOR GENERIC IN " &
  35                       "PARAMETERS ARE ONLY EVALUATED IF THERE ARE " &
  36                       "NO ACTUAL PARAMETERS");
  37      DECLARE
  38           TYPE ENUM IS (I, II, III);
  39           OBJ_INT : INTEGER := 1;
  40           OBJ_ENUM : ENUM := I;
  41
  42           GENERIC
  43                GEN_INT : IN INTEGER := IDENT_INT(2);
  44                GEN_BOOL : IN BOOLEAN := IDENT_BOOL(FALSE);
  45                GEN_ENUM : IN ENUM := II;
  46           PACKAGE P IS
  47                PAC_INT : INTEGER := GEN_INT;
  48                PAC_BOOL : BOOLEAN := GEN_BOOL;
  49                PAC_ENUM : ENUM := GEN_ENUM;
  50           END P;
  51
  52           PACKAGE P1 IS NEW P;
  53           PACKAGE P2 IS
  54                NEW P (IDENT_INT(OBJ_INT), GEN_ENUM => OBJ_ENUM);
  55           PACKAGE P3 IS NEW P (GEN_BOOL => IDENT_BOOL(TRUE));
  56      BEGIN
  57           IF P1.PAC_INT /= 2 OR P1.PAC_BOOL OR P1.PAC_ENUM /= II THEN
  58                FAILED ("DEFAULT VALUES WERE NOT EVALUATED");
  59           END IF;
  60           IF P2.PAC_INT /= 1 OR P2.PAC_BOOL OR P2.PAC_ENUM /= I THEN
  61                FAILED ("DEFAULT VALUES WERE NOT EVALUATED CORRECTLY " &
  62                        "- 1");
  63           END IF;
  64           IF P3.PAC_INT /= 2 OR NOT(P3.PAC_BOOL) OR
  65                P3.PAC_ENUM /= II THEN
  66                FAILED ("DEFAULT VALUES WERE NOT EVALUATED CORRECTLY " &
  67                        "- 2");
  68           END IF;
  69      END;
  70
  71      -------------------------------------------------------------------
  72      DECLARE
  73           OBJ_INT1 : INTEGER := 3;
  74
  75           FUNCTION FUNC (X : INTEGER) RETURN INTEGER;
  76
  77           GENERIC
  78                GEN_INT1 : IN INTEGER := FUNC (1);
  79                GEN_INT2 : IN INTEGER := FUNC (GEN_INT1 + 1);
  80           PROCEDURE PROC;
  81
  82           PROCEDURE PROC IS
  83                PROC_INT1 : INTEGER := GEN_INT1;
  84                PROC_INT2 : INTEGER := GEN_INT2;
  85           BEGIN
  86                IF PROC_INT1 /= 3 THEN
  87                     FAILED ("DEFAULT VALUES WERE NOT EVALUATED " &
  88                             "CORRECTLY - 3");
  89                END IF;
  90                IF PROC_INT2 /= 4 THEN
  91                     FAILED ("DEFAULT VALUES WERE NOT EVALUATED " &
  92                             "CORRECTLY - 4");
  93                END IF;
  94           END PROC;
  95
  96           FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS
  97           BEGIN
  98                IF X /= IDENT_INT(4) THEN
  99                     FAILED ("DEFAULT VALUES WERE NOT EVALUATED " &
 100                             "CORRECTLY - 5");
 101                END IF;
 102                RETURN IDENT_INT(X);
 103           END FUNC;
 104
 105           PROCEDURE NEW_PROC IS NEW PROC (GEN_INT1 => OBJ_INT1);
 106
 107      BEGIN
 108           NEW_PROC;
 109      END;
 110
 111      -------------------------------------------------------------------
 112      DECLARE
 113           TYPE ARA_TYP IS ARRAY (1 .. 2) OF INTEGER;
 114           TYPE REC IS
 115                RECORD
 116                     ANS : BOOLEAN;
 117                     ARA : ARA_TYP;
 118                END RECORD;
 119           TYPE ARA_REC IS ARRAY (1 .. 5) OF REC;
 120
 121           FUNCTION F (X : INTEGER) RETURN INTEGER;
 122
 123           OBJ_REC : REC := (FALSE, (3, 4));
 124           OBJ_ARA : ARA_REC := (1 .. 5 => (FALSE, (3, 4)));
 125
 126           GENERIC
 127                GEN_OBJ1 : IN ARA_TYP := (F(1), 2);
 128                GEN_OBJ2 : IN REC := (TRUE, GEN_OBJ1);
 129                GEN_OBJ3 : IN ARA_REC := (1 .. F(5) => (TRUE, (1, 2)));
 130           FUNCTION FUNC RETURN INTEGER;
 131
 132           FUNCTION FUNC RETURN INTEGER IS
 133           BEGIN
 134                RETURN IDENT_INT(1);
 135           END FUNC;
 136
 137           FUNCTION F (X : INTEGER) RETURN INTEGER IS
 138           BEGIN
 139                FAILED ("DEFAULT VALUES WERE EVALUATED - 1");
 140                RETURN IDENT_INT(X);
 141           END F;
 142
 143           FUNCTION NEW_FUNC IS NEW FUNC ((3, 4), OBJ_REC, OBJ_ARA);
 144
 145      BEGIN
 146           IF NOT EQUAL (NEW_FUNC, 1) THEN
 147                FAILED ("INCORRECT RESULT FROM GENERIC FUNCTION - 1");
 148           END IF;
 149      END;
 150
 151      -------------------------------------------------------------------
 152      DECLARE
 153           SUBTYPE INT IS INTEGER RANGE 1 .. 5;
 154           TYPE ARA_TYP IS ARRAY (1 .. 2) OF INTEGER;
 155           TYPE COLOR IS (RED, WHITE);
 156           TYPE CON_REC (D : INT) IS
 157                RECORD
 158                     A : COLOR;
 159                     B : ARA_TYP;
 160                END RECORD;
 161           TYPE UNCON_OR_CON_REC (D : INT := 2) IS
 162                RECORD
 163                     A : COLOR;
 164                     B : ARA_TYP;
 165                END RECORD;
 166           FUNCTION F (X : COLOR) RETURN COLOR;
 167
 168           OBJ_CON1 : CON_REC (1) := (1, WHITE, (3, 4));
 169           OBJ_UNCON : UNCON_OR_CON_REC := (2, WHITE, (3, 4));
 170           OBJ_CON2 : UNCON_OR_CON_REC (3) := (3, WHITE, (3, 4));
 171
 172           GENERIC
 173                GEN_CON1 : IN CON_REC := (2, F(RED), (1, 2));
 174                GEN_UNCON : IN UNCON_OR_CON_REC := (2, F(RED), (1, 2));
 175                GEN_CON2 : IN UNCON_OR_CON_REC := GEN_UNCON;
 176           FUNCTION FUNC RETURN INTEGER;
 177
 178           FUNCTION FUNC RETURN INTEGER IS
 179           BEGIN
 180                RETURN IDENT_INT(1);
 181           END FUNC;
 182
 183           FUNCTION F (X : COLOR) RETURN COLOR IS
 184           BEGIN
 185                FAILED ("DEFAULT VALUES WERE EVALUATED - 2");
 186                RETURN WHITE;
 187           END F;
 188
 189           FUNCTION NEW_FUNC IS NEW FUNC (OBJ_CON1, OBJ_UNCON, OBJ_CON2);
 190
 191      BEGIN
 192           IF NOT EQUAL (NEW_FUNC, 1) THEN
 193                FAILED ("INCORRECT RESULT FROM GENERIC FUNCTION - 2");
 194           END IF;
 195      END;
 196
 197      RESULT;
 198 END CC3123A;