gcc/testsuite/ada/acats/tests/cc/cc3128a.ada

   1 -- CC3128A.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, FOR A CONSTRAINED IN FORMAL PARAMETER HAVING AN ACCESS TYPE,
  27 --     CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL PARAMETER IS NOT
  28 --     NULL AND THE OBJECT DESIGNATED BY THE ACTUAL PARAMETER DOES NOT SATISFY
  29 --     THE FORMAL PARAMETER'S CONSTRAINTS.
  30
  31 -- HISTORY:
  32 --     RJW 10/28/88  CREATED ORIGINAL TEST.
  33 --     JRL 02/28/96  Removed cases where the designated subtypes of the formal
  34 --                   and actual do not statically match. Corrected commentary.
  35
  36 WITH REPORT; USE REPORT;
  37 PROCEDURE CC3128A IS
  38
  39 BEGIN
  40      TEST ("CC3128A", "FOR A CONSTRAINED IN FORMAL PARAMETER HAVING " &
  41                       "AN ACCESS TYPE, CONSTRAINT_ERROR IS RAISED " &
  42                       "IF AND ONLY IF THE ACTUAL PARAMETER IS NOT " &
  43                       "NULL AND THE OBJECT DESIGNATED BY THE ACTUAL " &
  44                       "PARAMETER DOES NOT SATISFY FORMAL PARAMETER'S " &
  45                       "CONSTRAINTS");
  46
  47      DECLARE
  48           TYPE REC (D : INTEGER := 10) IS
  49                RECORD
  50                     NULL;
  51                END RECORD;
  52
  53           TYPE ACCREC IS ACCESS REC;
  54
  55           SUBTYPE LINK IS ACCREC (5);
  56
  57           GENERIC
  58                LINK1 : LINK;
  59           FUNCTION F (I : INTEGER) RETURN INTEGER;
  60
  61           FUNCTION F (I : INTEGER) RETURN INTEGER IS
  62           BEGIN
  63                IF I /= 5 THEN
  64                     FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
  65                             "TO CALL TO FUNCTION F - 1");
  66                END IF;
  67                IF NOT EQUAL (I, 5) AND THEN
  68                   NOT EQUAL (LINK1.D, LINK1.D) THEN
  69                     COMMENT ("DISREGARD");
  70                END IF;
  71                RETURN I + 1;
  72           EXCEPTION
  73                WHEN OTHERS =>
  74                     FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 1");
  75                RETURN I + 1;
  76           END F;
  77
  78           GENERIC
  79                TYPE PRIV (D : INTEGER) IS PRIVATE;
  80                PRIV1 : PRIV;
  81           PACKAGE GEN IS
  82                TYPE ACCPRIV IS ACCESS PRIV;
  83                SUBTYPE LINK IS ACCPRIV (5);
  84                GENERIC
  85                     LINK1 : LINK;
  86                     I : IN OUT INTEGER;
  87                PACKAGE P IS END P;
  88           END GEN;
  89
  90           PACKAGE BODY GEN IS
  91                PACKAGE BODY P IS
  92                BEGIN
  93                     IF I /= 5 THEN
  94                          FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
  95                                  "TO PACKAGE BODY P - 1");
  96                     END IF;
  97                     IF NOT EQUAL (I, 5) AND THEN
  98                        NOT EQUAL (LINK1.D, LINK1.D) THEN
  99                          COMMENT ("DISREGARD");
 100                     END IF;
 101                     I := I + 1;
 102                EXCEPTION
 103                     WHEN OTHERS =>
 104                          FAILED ("EXCEPTION RAISED WITHIN " &
 105                                  "PACKAGE P - 1");
 106                     I := I + 1;
 107                END P;
 108
 109           BEGIN
 110                BEGIN
 111                     DECLARE
 112                          AR10 : ACCPRIV;
 113                          I : INTEGER := IDENT_INT (5);
 114                          PACKAGE P1 IS NEW P (AR10, I);
 115                     BEGIN
 116                          IF I /= 6 THEN
 117                               FAILED ("INCORRECT RESULT - " &
 118                                       "PACKAGE P1");
 119                          END IF;
 120                     EXCEPTION
 121                          WHEN OTHERS =>
 122                               FAILED ("EXCEPTION RAISED TOO LATE - " &
 123                                       "PACKAGE P1 - 1");
 124                     END;
 125                EXCEPTION
 126                     WHEN OTHERS =>
 127                          FAILED ("EXCEPTION RAISED AT INSTANTIATION " &
 128                                  "OF PACKAGE P1 WITH NULL ACCESS " &
 129                                  "VALUE");
 130                END;
 131
 132                BEGIN
 133                     DECLARE
 134                          AR10 : ACCPRIV := NEW PRIV'(PRIV1);
 135                          I : INTEGER := IDENT_INT (0);
 136                          PACKAGE P1 IS NEW P (AR10, I);
 137                     BEGIN
 138                          FAILED ("NO EXCEPTION RAISED BY " &
 139                                  "INSTANTIATION OF PACKAGE P1");
 140                     EXCEPTION
 141                          WHEN OTHERS =>
 142                               FAILED ("EXCEPTION RAISED TOO LATE - " &
 143                                       "PACKAGE P1 - 2");
 144                     END;
 145                EXCEPTION
 146                     WHEN CONSTRAINT_ERROR =>
 147                          NULL;
 148                     WHEN OTHERS =>
 149                          FAILED ("WRONG EXCEPTION RAISED AT " &
 150                                  "INSTANTIATION OF PACKAGE P1");
 151                END;
 152           END GEN;
 153
 154           PACKAGE NEWGEN IS NEW GEN (REC, (D => 10));
 155
 156      BEGIN
 157           BEGIN
 158                DECLARE
 159                     I : INTEGER := IDENT_INT (5);
 160                     AR10 : ACCREC;
 161                     FUNCTION F1 IS NEW F (AR10);
 162                BEGIN
 163                     I := F1 (I);
 164                     IF I /= 6 THEN
 165                          FAILED ("INCORRECT RESULT RETURNED BY " &
 166                                  "FUNCTION F1");
 167                     END IF;
 168                EXCEPTION
 169                     WHEN OTHERS =>
 170                          FAILED ("EXCEPTION RAISED AT CALL TO " &
 171                                  "FUNCTION F1 - 1");
 172                END;
 173           EXCEPTION
 174                WHEN OTHERS =>
 175                     FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " &
 176                             "FUNCTION F1 WITH NULL ACCESS VALUE");
 177           END;
 178
 179           BEGIN
 180                DECLARE
 181                     I : INTEGER := IDENT_INT (0);
 182                     AR10 : ACCREC := NEW REC'(D => 10);
 183                     FUNCTION F1 IS NEW F (AR10);
 184                BEGIN
 185                     FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " &
 186                             "OF FUNCTION F1");
 187                     I := F1 (I);
 188                EXCEPTION
 189                     WHEN OTHERS =>
 190                          FAILED ("EXCEPTION RAISED AT CALL TO " &
 191                                  "FUNCTION F1 - 2");
 192                END;
 193           EXCEPTION
 194                WHEN CONSTRAINT_ERROR =>
 195                     NULL;
 196                WHEN OTHERS =>
 197                     FAILED ("WRONG EXCEPTION RAISED AT " &
 198                             "INSTANTIATION OF FUNCTION F1");
 199           END;
 200      END;
 201
 202      DECLARE
 203           TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
 204
 205           TYPE ACCARR IS ACCESS ARR;
 206
 207           SUBTYPE LINK IS ACCARR (1 .. 5);
 208
 209           GENERIC
 210                LINK1 : LINK;
 211           FUNCTION F (I : INTEGER) RETURN INTEGER;
 212
 213           FUNCTION F (I : INTEGER) RETURN INTEGER IS
 214           BEGIN
 215                IF I /= 5 THEN
 216                     FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
 217                             "TO CALL TO FUNCTION F - 2");
 218                END IF;
 219                IF NOT EQUAL (I, 5) AND THEN
 220                   NOT EQUAL (LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3)))
 221                   THEN
 222                     COMMENT ("DISREGARD");
 223                END IF;
 224                RETURN I + 1;
 225           EXCEPTION
 226                WHEN OTHERS =>
 227                     FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 2");
 228                RETURN I + 1;
 229           END F;
 230
 231           GENERIC
 232                TYPE GENARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
 233           PACKAGE GEN IS
 234                TYPE ACCGENARR IS ACCESS GENARR;
 235                SUBTYPE LINK IS ACCGENARR (1 .. 5);
 236                GENERIC
 237                     LINK1 : LINK;
 238                     I : IN OUT INTEGER;
 239                PACKAGE P IS END P;
 240           END GEN;
 241
 242           PACKAGE BODY GEN IS
 243                PACKAGE BODY P IS
 244                BEGIN
 245                     IF I /= 5 THEN
 246                          FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
 247                                  "TO PACKAGE BODY P - 2");
 248                     END IF;
 249                     IF NOT EQUAL (I, 5) AND THEN
 250                        NOT
 251                        EQUAL(LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3)))
 252                        THEN
 253                          COMMENT ("DISREGARD");
 254                     END IF;
 255                     I := I + 1;
 256                EXCEPTION
 257                     WHEN OTHERS =>
 258                          FAILED ("EXCEPTION RAISED WITHIN " &
 259                                  "PACKAGE P - 2");
 260                     I := I + 1;
 261                END P;
 262
 263           BEGIN
 264                BEGIN
 265                     DECLARE
 266                          AR26 : ACCGENARR (2 .. 6);
 267                          I : INTEGER := IDENT_INT (5);
 268                          PACKAGE P2 IS NEW P (AR26, I);
 269                     BEGIN
 270                          IF I /= 6 THEN
 271                               FAILED ("INCORRECT RESULT - " &
 272                                       "PACKAGE P2");
 273                          END IF;
 274                     EXCEPTION
 275                          WHEN OTHERS =>
 276                               FAILED ("EXCEPTION RAISED TOO LATE - " &
 277                                       "PACKAGE P2 - 1");
 278                     END;
 279                EXCEPTION
 280                     WHEN OTHERS =>
 281                          FAILED ("EXCEPTION RAISED AT INSTANTIATION " &
 282                                  "OF PACKAGE P2 WITH NULL ACCESS " &
 283                                  "VALUE");
 284                END;
 285
 286                BEGIN
 287                     DECLARE
 288                          AR26 : ACCGENARR
 289                                 (IDENT_INT (2) .. IDENT_INT (6)) :=
 290                                 NEW GENARR'(1,2,3,4,5);
 291                          I : INTEGER := IDENT_INT (0);
 292                          PACKAGE P2 IS NEW P (AR26, I);
 293                     BEGIN
 294                          FAILED ("NO EXCEPTION RAISED BY " &
 295                                  "INSTANTIATION OF PACKAGE P2");
 296                     EXCEPTION
 297                          WHEN OTHERS =>
 298                               FAILED ("EXCEPTION RAISED TOO LATE - " &
 299                                       "PACKAGE P2 - 2");
 300                     END;
 301                EXCEPTION
 302                     WHEN CONSTRAINT_ERROR =>
 303                          NULL;
 304                     WHEN OTHERS =>
 305                          FAILED ("WRONG EXCEPTION RAISED AT " &
 306                                  "INSTANTIATION OF PACKAGE P2");
 307                END;
 308           END GEN;
 309
 310           PACKAGE NEWGEN IS NEW GEN (ARR);
 311
 312      BEGIN
 313           BEGIN
 314                DECLARE
 315                     I : INTEGER := IDENT_INT (5);
 316                     AR26 : ACCARR (IDENT_INT (2) .. IDENT_INT (6));
 317                     FUNCTION F2 IS NEW F (AR26);
 318                BEGIN
 319                     I := F2 (I);
 320                     IF I /= 6 THEN
 321                          FAILED ("INCORRECT RESULT RETURNED BY " &
 322                                  "FUNCTION F2");
 323                     END IF;
 324                EXCEPTION
 325                     WHEN OTHERS =>
 326                          FAILED ("EXCEPTION RAISED AT CALL TO " &
 327                                  "FUNCTION F2 - 1");
 328                END;
 329           EXCEPTION
 330                WHEN OTHERS =>
 331                     FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " &
 332                             "FUNCTION F2 WITH NULL ACCESS VALUE");
 333           END;
 334
 335           BEGIN
 336                DECLARE
 337                     I : INTEGER := IDENT_INT (0);
 338                     AR26 : ACCARR (2 .. 6) := NEW ARR'(1,2,3,4,5);
 339                     FUNCTION F2 IS NEW F (AR26);
 340                BEGIN
 341                     FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " &
 342                             "OF FUNCTION F2");
 343                     I := F2 (I);
 344                EXCEPTION
 345                     WHEN OTHERS =>
 346                          FAILED ("EXCEPTION RAISED AT CALL TO " &
 347                                  "FUNCTION F2 - 2");
 348                END;
 349           EXCEPTION
 350                WHEN CONSTRAINT_ERROR =>
 351                     NULL;
 352                WHEN OTHERS =>
 353                     FAILED ("WRONG EXCEPTION RAISED AT " &
 354                             "INSTANTIATION OF FUNCTION F2");
 355           END;
 356      END;
 357      RESULT;
 358 END CC3128A;