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

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