gcc/testsuite/ada/acats/tests/c3/c34005r.ada

   1 -- C34005R.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 --     FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
  27 --     LIMITED TYPE:
  28
  29 --        CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
  30 --        FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
  31 --        IS CONSTRAINED.
  32
  33 --        CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
  34 --        ALSO IMPOSED ON THE DERIVED SUBTYPE.
  35
  36 -- HISTORY:
  37 --     JRK 08/19/87  CREATED ORIGINAL TEST.
  38 --     VCL 07/01/88  ADDED EXCEPTION HANDLERS TO CATCH INCORRECT TYPE
  39 --                   CONVERSIONS TO DERIVED SUBTYPES.
  40
  41 WITH REPORT; USE REPORT;
  42
  43 PROCEDURE C34005R IS
  44
  45      PACKAGE PKG_L IS
  46
  47           TYPE LP IS LIMITED PRIVATE;
  48
  49           FUNCTION CREATE (X : INTEGER) RETURN LP;
  50
  51           FUNCTION VALUE (X : LP) RETURN INTEGER;
  52
  53           FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
  54
  55           PROCEDURE ASSIGN (X : OUT LP; Y : LP);
  56
  57           C1 : CONSTANT LP;
  58           C2 : CONSTANT LP;
  59           C3 : CONSTANT LP;
  60           C4 : CONSTANT LP;
  61           C5 : CONSTANT LP;
  62
  63      PRIVATE
  64
  65           TYPE LP IS NEW INTEGER;
  66
  67           C1 : CONSTANT LP := 1;
  68           C2 : CONSTANT LP := 2;
  69           C3 : CONSTANT LP := 3;
  70           C4 : CONSTANT LP := 4;
  71           C5 : CONSTANT LP := 5;
  72
  73      END PKG_L;
  74
  75      USE PKG_L;
  76
  77      SUBTYPE COMPONENT IS LP;
  78
  79      PACKAGE PKG_P IS
  80
  81           FIRST : CONSTANT := 0;
  82           LAST  : CONSTANT := 100;
  83
  84           SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
  85
  86           TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
  87
  88           FUNCTION CREATE ( F, L  : INDEX;
  89                             C     : COMPONENT;
  90                             DUMMY : PARENT   -- TO RESOLVE OVERLOADING.
  91                           ) RETURN PARENT;
  92
  93           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
  94
  95           FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT;
  96
  97           FUNCTION AGGR (W, X, Y, Z : COMPONENT) RETURN PARENT;
  98
  99      END PKG_P;
 100
 101      USE PKG_P;
 102
 103      TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
 104
 105      SUBTYPE SUBPARENT IS PARENT (5 .. 7);
 106
 107      TYPE S IS NEW SUBPARENT;
 108
 109      X : T;
 110      Y : S;
 111
 112      PACKAGE BODY PKG_L IS
 113
 114           FUNCTION CREATE (X : INTEGER) RETURN LP IS
 115           BEGIN
 116                RETURN LP (IDENT_INT (X));
 117           END CREATE;
 118
 119           FUNCTION VALUE (X : LP) RETURN INTEGER IS
 120           BEGIN
 121                RETURN INTEGER (X);
 122           END VALUE;
 123
 124           FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
 125           BEGIN
 126                RETURN X = Y;
 127           END EQUAL;
 128
 129           PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
 130           BEGIN
 131                X := Y;
 132           END ASSIGN;
 133
 134      END PKG_L;
 135
 136      PACKAGE BODY PKG_P IS
 137
 138           FUNCTION CREATE
 139              ( F, L  : INDEX;
 140                C     : COMPONENT;
 141                DUMMY : PARENT
 142              ) RETURN PARENT
 143           IS
 144                A : PARENT (F .. L);
 145                B : COMPONENT;
 146           BEGIN
 147                ASSIGN (B, C);
 148                FOR I IN F .. L LOOP
 149                     ASSIGN (A (I), B);
 150                     ASSIGN (B, CREATE (VALUE (B) + 1));
 151                END LOOP;
 152                RETURN A;
 153           END CREATE;
 154
 155           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
 156           BEGIN
 157                IF X'LENGTH /= Y'LENGTH THEN
 158                     RETURN FALSE;
 159                ELSE FOR I IN X'RANGE LOOP
 160                          IF NOT EQUAL (X (I),
 161                                        Y (I - X'FIRST + Y'FIRST)) THEN
 162                               RETURN FALSE;
 163                          END IF;
 164                     END LOOP;
 165                END IF;
 166                RETURN TRUE;
 167           END EQUAL;
 168
 169           FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS
 170                RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1);
 171           BEGIN
 172                ASSIGN (RESULT (INDEX'FIRST    ), X);
 173                ASSIGN (RESULT (INDEX'FIRST + 1), Y);
 174                RETURN RESULT;
 175           END AGGR;
 176
 177           FUNCTION AGGR (W, X, Y, Z : COMPONENT) RETURN PARENT IS
 178                RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 3);
 179           BEGIN
 180                ASSIGN (RESULT (INDEX'FIRST    ), W);
 181                ASSIGN (RESULT (INDEX'FIRST + 1), X);
 182                ASSIGN (RESULT (INDEX'FIRST + 2), Y);
 183                ASSIGN (RESULT (INDEX'FIRST + 3), Z);
 184                RETURN RESULT;
 185           END AGGR;
 186
 187      END PKG_P;
 188
 189      PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS
 190      BEGIN
 191           FOR I IN X'RANGE LOOP
 192                ASSIGN (X (I), Y (I));
 193           END LOOP;
 194      END ASSIGN;
 195
 196      PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS
 197      BEGIN
 198           FOR I IN X'RANGE LOOP
 199                ASSIGN (X (I), Y (I));
 200           END LOOP;
 201      END ASSIGN;
 202
 203 BEGIN
 204      TEST ("C34005R", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
 205                       "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
 206                       "WHEN THE DERIVED TYPE DEFINITION IS " &
 207                       "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
 208                       "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
 209                       "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
 210                       "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
 211                       "TYPE IS A LIMITED TYPE");
 212
 213      ASSIGN (X (IDENT_INT (5)), CREATE (2));
 214      ASSIGN (X (IDENT_INT (6)), CREATE (3));
 215      ASSIGN (X (IDENT_INT (7)), CREATE (4));
 216
 217      ASSIGN (Y (5), C2);
 218      ASSIGN (Y (6), C3);
 219      ASSIGN (Y (7), C4);
 220
 221      -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
 222
 223      BEGIN
 224           IF NOT EQUAL (CREATE (2, 3, C4, X), AGGR (C4, C5)) THEN
 225                FAILED ("CANNOT CREATE BASE TYPE VALUES OUTSIDE " &
 226                        "OF THE SUBTYPE T");
 227           END IF;
 228      EXCEPTION
 229           WHEN OTHERS =>
 230                FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " &
 231                        "VALUES OUTSIDE OF THE SUBTYPE T");
 232      END;
 233
 234      BEGIN
 235           IF NOT EQUAL (CREATE (2, 3, C4, Y), AGGR (C4, C5)) THEN
 236                FAILED ("CANNOT CREATE BASE TYPE VALUES OUTSIDE " &
 237                        "OF THE SUBTYPE S");
 238           END IF;
 239      EXCEPTION
 240           WHEN OTHERS =>
 241                FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " &
 242                        "VALUES OUTSIDE OF THE SUBTYPE S");
 243      END;
 244
 245      BEGIN
 246           IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)),
 247                         AGGR (C3, C4))                     THEN
 248                FAILED ("INCORRECT SLICE OF X (VALUE)");
 249           END IF;
 250      EXCEPTION
 251           WHEN OTHERS =>
 252                FAILED ("EXCEPTION RAISED WHILE CHECKING SLICE OF X");
 253      END;
 254
 255      BEGIN
 256           IF NOT EQUAL (AGGR (C3, C4),
 257                         Y(IDENT_INT (6)..IDENT_INT (7)))  THEN
 258                FAILED ("INCORRECT SLICE OF Y (VALUE)");
 259           END IF;
 260      EXCEPTION
 261           WHEN OTHERS =>
 262                FAILED ("EXCEPTION RAISED WHILE CHECKING SLICE OF Y");
 263      END;
 264
 265      -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
 266
 267      IF T'FIRST /= 5 OR T'LAST /= 7 OR
 268         S'FIRST /= 5 OR S'LAST /= 7 THEN
 269           FAILED ("INCORRECT 'FIRST OR 'LAST");
 270      END IF;
 271
 272      BEGIN
 273           ASSIGN (X, CREATE (5, 7, C1, X));
 274           ASSIGN (Y, CREATE (5, 7, C1, Y));
 275           IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN  -- USE X AND Y.
 276                FAILED ("INCORRECT CONVERSION TO PARENT");
 277           END IF;
 278      EXCEPTION
 279           WHEN OTHERS =>
 280                FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
 281      END;
 282
 283      BEGIN
 284           ASSIGN (X, AGGR (C1, C2));
 285           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 286                   "ASSIGN (X, AGGR (C1, C2))");
 287           IF EQUAL (X, AGGR (C1, C2)) THEN  -- USE X.
 288                COMMENT ("X ALTERED -- ASSIGN (X, AGGR (C1, C2))");
 289           END IF;
 290      EXCEPTION
 291           WHEN CONSTRAINT_ERROR =>
 292                NULL;
 293           WHEN OTHERS =>
 294                FAILED ("WRONG EXCEPTION RAISED -- " &
 295                        "ASSIGN (X, AGGR (C1, C2))");
 296      END;
 297
 298      BEGIN
 299           ASSIGN (X, AGGR (C1, C2, C3, C4));
 300           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 301                   "ASSIGN (X, AGGR (C1, C2, C3, C4))");
 302           IF EQUAL (X, AGGR (C1, C2, C3, C4)) THEN  -- USE X.
 303                COMMENT ("X ALTERED -- " &
 304                         "ASSIGN (X, AGGR (C1, C2, C3, C4))");
 305           END IF;
 306      EXCEPTION
 307           WHEN CONSTRAINT_ERROR =>
 308                NULL;
 309           WHEN OTHERS =>
 310                FAILED ("WRONG EXCEPTION RAISED -- " &
 311                        "ASSIGN (X, AGGR (C1, C2, C3, C4))");
 312      END;
 313
 314      BEGIN
 315           ASSIGN (Y, AGGR (C1, C2));
 316           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 317                   "ASSIGN (Y, AGGR (C1, C2))");
 318           IF EQUAL (Y, AGGR (C1, C2)) THEN  -- USE Y.
 319                COMMENT ("Y ALTERED -- ASSIGN (Y, AGGR (C1, C2))");
 320           END IF;
 321      EXCEPTION
 322           WHEN CONSTRAINT_ERROR =>
 323                NULL;
 324           WHEN OTHERS =>
 325                FAILED ("WRONG EXCEPTION RAISED -- " &
 326                        "ASSIGN (Y, AGGR (C1, C2))");
 327      END;
 328
 329      BEGIN
 330           ASSIGN (Y, AGGR (C1, C2, C3, C4));
 331           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 332                   "ASSIGN (Y, AGGR (C1, C2, C3, C4))");
 333           IF EQUAL (Y, AGGR (C1, C2, C3, C4)) THEN  -- USE Y.
 334                COMMENT ("Y ALTERED -- " &
 335                         "ASSIGN (Y, AGGR (C1, C2, C3, C4))");
 336           END IF;
 337      EXCEPTION
 338           WHEN CONSTRAINT_ERROR =>
 339                NULL;
 340           WHEN OTHERS =>
 341                FAILED ("WRONG EXCEPTION RAISED -- " &
 342                        "ASSIGN (Y, AGGR (C1, C2, C3, C4))");
 343      END;
 344
 345      RESULT;
 346 END C34005R;