gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c37213j.ada

   1 -- C37213J.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, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN
  27 --     INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE
  28 --     RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN
  29 --     OBJECT OR A SUBTYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS
  30 --     OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY:
  31 --          1) ONLY IN AN OBJECT DECLARATION, AND
  32 --          2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT
  33 --             IN THE SUBTYPE.
  34
  35 -- HISTORY:
  36 --     JBG  10/17/86  CREATED ORIGINAL TEST.
  37 --     VCL  10/23/87  MODIFIED THIS HEADER; SEPARATED THIS TEST INTO
  38 --                    3 NEW TESTS (J,K,L); CHANGED THE AGGREGATE FOR
  39 --                    THE PARAMETER 'VALUE' IN THE CALL OF PROCEDURE
  40 --                    'SUBTYPE_CHK1';  MOVED THE CALL TO REPORT.TEST
  41 --                    SO THAT IT COMES BEFORE ANY DECLARATIONS; ADDED
  42 --                    A SEQUENCE COUNTER TO IDENTIFY WHICH SUBTEST
  43 --                    DECLARATION PART RAISES CONSTRAINT_ERROR.
  44 --     VCL  03/28/88  MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY
  45 --                    DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL
  46 --                    PARAMETERS TO THE GENERIC UNITS AND THE
  47 --                    CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE
  48 --                    TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE
  49 --                    ARE TOGETHER.
  50
  51 WITH REPORT; USE REPORT;
  52 PROCEDURE C37213J IS
  53 BEGIN
  54      TEST ("C37213J", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " &
  55                       "OR AN INDEX CONSTRAINT THAT DEPEND ON A " &
  56                       "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " &
  57                       "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " &
  58                       "USED AS THE ACTUAL PARAMETER TO A GENERIC " &
  59                       "FORMAL TYPE USED TO DECLARE AN OBJECT OR A " &
  60                       "SUBTYPE");
  61
  62      DECLARE
  63           SUBTYPE SM IS INTEGER RANGE 1..10;
  64           TYPE REC (D1, D2 : SM) IS
  65                RECORD NULL; END RECORD;
  66           TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
  67
  68           SEQUENCE_NUMBER : INTEGER;
  69
  70           GENERIC
  71                TYPE CONS IS PRIVATE;
  72                OBJ_XCP : BOOLEAN;
  73                TAG     : STRING;
  74           PACKAGE OBJ_CHK IS END OBJ_CHK;
  75
  76           GENERIC
  77                TYPE CONS IS PRIVATE;
  78           PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN;
  79                                 TAG     : STRING);
  80
  81           PACKAGE BODY OBJ_CHK IS
  82           BEGIN          -- DECLARE AN OBJECT OF THE FORMAL TYPE.
  83                DECLARE
  84                     X : CONS;
  85
  86                     FUNCTION VALUE RETURN CONS IS
  87                     BEGIN
  88                          IF EQUAL (3,3) THEN
  89                               RETURN X;
  90                          ELSE
  91                               RETURN X;
  92                          END IF;
  93                     END VALUE;
  94                BEGIN
  95                     IF OBJ_XCP THEN
  96                          FAILED ("NO CHECK DURING DECLARATION " &
  97                                  "OF OBJECT OF TYPE CONS - " & TAG);
  98                     ELSIF X /= VALUE THEN
  99                          FAILED ("INCORRECT VALUE FOR OBJECT OF " &
 100                                  "TYPE CONS - " & TAG);
 101                     END IF;
 102                END;
 103           EXCEPTION
 104                WHEN CONSTRAINT_ERROR =>
 105                     IF NOT OBJ_XCP THEN
 106                          FAILED ("IMPROPER CONSTRAINT CHECKED " &
 107                                  "DURING DECLARATION OF OBJECT " &
 108                                  "OF TYPE CONS - " & TAG);
 109                     END IF;
 110           END OBJ_CHK;
 111
 112           PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN;
 113                                 TAG     : STRING)    IS
 114           BEGIN          -- DECLARE A SUBTYPE OF THE FORMAL TYPE.
 115                DECLARE
 116                     SUBTYPE SCONS IS CONS;
 117                BEGIN
 118                     DECLARE
 119                          X : SCONS;
 120
 121                          FUNCTION VALUE RETURN SCONS IS
 122                          BEGIN
 123                               IF EQUAL (5, 5) THEN
 124                                    RETURN X;
 125                               ELSE
 126                                    RETURN X;
 127                               END IF;
 128                          END VALUE;
 129                     BEGIN
 130                          IF OBJ_XCP THEN
 131                               FAILED ("NO CHECK DURING DECLARATION " &
 132                                       "OF OBJECT OF SUBTYPE SCONS - " &
 133                                       TAG);
 134                          ELSIF X /= VALUE THEN
 135                               FAILED ("INCORRECT VALUE FOR OBJECT " &
 136                                       "OF SUBTYPE SCONS - " & TAG);
 137                          END IF;
 138                     END;
 139                EXCEPTION
 140                     WHEN CONSTRAINT_ERROR =>
 141                          IF NOT OBJ_XCP THEN
 142                               FAILED ("IMPROPER CONSTRAINT CHECKED " &
 143                                       "DURING DECLARATION OF OBJECT " &
 144                                       "OF SUBTYPE SCONS - " & TAG);
 145                          END IF;
 146                END;
 147           EXCEPTION
 148                WHEN CONSTRAINT_ERROR =>
 149                     FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
 150                             "DURING SUBTYPE DECLARATION - " & TAG);
 151           END SUBTYP_CHK;
 152      BEGIN
 153           SEQUENCE_NUMBER := 1;
 154           DECLARE
 155                TYPE REC_DEF (D3 : INTEGER := 1) IS
 156                     RECORD
 157                          C1 : REC (D3, 0);
 158                     END RECORD;
 159
 160                PACKAGE PACK1 IS NEW OBJ_CHK (REC_DEF,
 161                          OBJ_XCP => TRUE,
 162                          TAG     => "PACK1");
 163
 164                PROCEDURE PROC1 IS NEW SUBTYP_CHK (REC_DEF);
 165           BEGIN
 166                PROC1 (OBJ_XCP => TRUE, TAG => "PROC1");
 167           END;
 168
 169           SEQUENCE_NUMBER := 2;
 170           DECLARE
 171                TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS
 172                     RECORD
 173                          C1 : MY_ARR (0..D3);
 174                     END RECORD;
 175
 176                PACKAGE PACK2 IS NEW OBJ_CHK (ARR_DEF,
 177                          OBJ_XCP => TRUE,
 178                          TAG     => "PACK2");
 179
 180                PROCEDURE PROC2 IS NEW SUBTYP_CHK (ARR_DEF);
 181           BEGIN
 182                PROC2 (OBJ_XCP => TRUE, TAG => "PROC2");
 183           END;
 184
 185
 186           SEQUENCE_NUMBER := 3;
 187           DECLARE
 188                TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS
 189                     RECORD
 190                          CASE D3 IS
 191                               WHEN -5..10 =>
 192                                    C1 : REC (D3, IDENT_INT(11));
 193                               WHEN OTHERS =>
 194                                    C2 : INTEGER := IDENT_INT(5);
 195                          END CASE;
 196                     END RECORD;
 197
 198                PACKAGE PACK3 IS NEW OBJ_CHK (VAR_REC_DEF1,
 199                               OBJ_XCP => TRUE,
 200                               TAG     => "PACK3");
 201
 202                PROCEDURE PROC3 IS NEW SUBTYP_CHK (VAR_REC_DEF1);
 203           BEGIN
 204                PROC3 (OBJ_XCP => TRUE, TAG => "PROC3");
 205           END;
 206
 207           SEQUENCE_NUMBER := 4;
 208           DECLARE
 209                TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS
 210                     RECORD
 211                          CASE D3 IS
 212                               WHEN -5..10 =>
 213                                    C1 : REC (D3, IDENT_INT(11));
 214                               WHEN OTHERS =>
 215                                    C2 : INTEGER := IDENT_INT(5);
 216                          END CASE;
 217                     END RECORD;
 218
 219                PACKAGE PACK4 IS NEW OBJ_CHK (VAR_REC_DEF6,
 220                               OBJ_XCP => FALSE,
 221                               TAG     => "PACK4");
 222
 223                PROCEDURE PROC4 IS NEW SUBTYP_CHK (VAR_REC_DEF6);
 224           BEGIN
 225                PROC4 (OBJ_XCP => FALSE,TAG => "PROC4");
 226           END;
 227
 228           SEQUENCE_NUMBER := 5;
 229           DECLARE
 230                TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS
 231                     RECORD
 232                          CASE D3 IS
 233                               WHEN -5..10 =>
 234                                    C1 : REC (D3, IDENT_INT(11));
 235                               WHEN OTHERS =>
 236                                    C2 : INTEGER := IDENT_INT(5);
 237                          END CASE;
 238                     END RECORD;
 239
 240                PACKAGE PACK5 IS NEW OBJ_CHK (VAR_REC_DEF11,
 241                               OBJ_XCP => FALSE,
 242                               TAG     => "PACK5");
 243
 244                PROCEDURE PROC5 IS NEW SUBTYP_CHK (VAR_REC_DEF11);
 245           BEGIN
 246                PROC5 (OBJ_XCP => FALSE, TAG => "PROC5");
 247           END;
 248
 249           SEQUENCE_NUMBER := 6;
 250           DECLARE
 251                TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS
 252                     RECORD
 253                          CASE D3 IS
 254                               WHEN -5..10 =>
 255                                    C1 : MY_ARR(D3..IDENT_INT(11));
 256                               WHEN OTHERS =>
 257                                    C2 : INTEGER := IDENT_INT(5);
 258                          END CASE;
 259                     END RECORD;
 260
 261                PACKAGE PACK6 IS NEW OBJ_CHK (VAR_ARR_DEF1,
 262                               OBJ_XCP => TRUE,
 263                               TAG     => "PACK6");
 264
 265                PROCEDURE PROC6 IS NEW SUBTYP_CHK (VAR_ARR_DEF1);
 266           BEGIN
 267                PROC6 (OBJ_XCP => TRUE, TAG => "PROC6");
 268           END;
 269
 270           SEQUENCE_NUMBER := 7;
 271           DECLARE
 272                TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS
 273                     RECORD
 274                          CASE D3 IS
 275                               WHEN -5..10 =>
 276                                    C1 : MY_ARR(D3..IDENT_INT(11));
 277                               WHEN OTHERS =>
 278                                    C2 : INTEGER := IDENT_INT(5);
 279                          END CASE;
 280                     END RECORD;
 281
 282                PACKAGE PACK7 IS NEW OBJ_CHK (VAR_ARR_DEF6,
 283                               OBJ_XCP => FALSE,
 284                               TAG     => "PACK7");
 285
 286                PROCEDURE PROC7 IS NEW SUBTYP_CHK (VAR_ARR_DEF6);
 287           BEGIN
 288                PROC7 (OBJ_XCP => FALSE, TAG => "PROC7");
 289           END;
 290
 291           SEQUENCE_NUMBER := 8;
 292           DECLARE
 293                TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS
 294                     RECORD
 295                          CASE D3 IS
 296                               WHEN -5..10 =>
 297                                    C1 : MY_ARR(D3..IDENT_INT(11));
 298                               WHEN OTHERS =>
 299                                    C2 : INTEGER := IDENT_INT(5);
 300                          END CASE;
 301                     END RECORD;
 302
 303                PACKAGE PACK8 IS NEW OBJ_CHK (VAR_ARR_DEF11,
 304                               OBJ_XCP => FALSE,
 305                               TAG     => "PACK8");
 306
 307                PROCEDURE PROC8 IS NEW SUBTYP_CHK (VAR_ARR_DEF11);
 308           BEGIN
 309                PROC8 (OBJ_XCP => FALSE, TAG => "PROC8");
 310           END;
 311
 312      EXCEPTION
 313           WHEN OTHERS =>
 314                FAILED ("EXCEPTION RAISED DURING DECLARATION / " &
 315                        "INSTANTIATION ELABORATION - " &
 316                        INTEGER'IMAGE(SEQUENCE_NUMBER));
 317      END;
 318
 319      RESULT;
 320 END C37213J;