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

   1 -- C34007I.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 -- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A MULTI-DIMENSIONAL
  26 -- ARRAY TYPE:
  27
  28 --   CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
  29 --   DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
  30 --   CONSTRAINED.
  31
  32 --   CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
  33 --   IMPOSED ON THE DERIVED SUBTYPE.
  34
  35 -- JRK 9/25/86
  36
  37 WITH REPORT; USE REPORT;
  38
  39 PROCEDURE C34007I IS
  40
  41      SUBTYPE COMPONENT IS INTEGER;
  42
  43      TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF
  44                               COMPONENT;
  45
  46      SUBTYPE SUBDESIGNATED IS DESIGNATED (4 .. 5, 6 .. 8);
  47
  48      PACKAGE PKG IS
  49
  50           TYPE PARENT IS ACCESS DESIGNATED;
  51
  52           FUNCTION CREATE ( F1, L1 : NATURAL;
  53                             F2, L2 : NATURAL;
  54                             C      : COMPONENT;
  55                             DUMMY  : PARENT   -- TO RESOLVE OVERLOADING.
  56                           ) RETURN PARENT;
  57
  58      END PKG;
  59
  60      USE PKG;
  61
  62      TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
  63                            IDENT_INT (6) .. IDENT_INT (8));
  64
  65      SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8);
  66
  67      TYPE S IS NEW SUBPARENT;
  68
  69      X : T := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
  70      Y : S := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
  71
  72      PACKAGE BODY PKG IS
  73
  74           FUNCTION CREATE
  75              ( F1, L1 : NATURAL;
  76                F2, L2 : NATURAL;
  77                C      : COMPONENT;
  78                DUMMY  : PARENT
  79              ) RETURN PARENT
  80           IS
  81                A : PARENT    := NEW DESIGNATED (F1 .. L1, F2 .. L2);
  82                B : COMPONENT := C;
  83           BEGIN
  84                FOR I IN F1 .. L1 LOOP
  85                     FOR J IN F2 .. L2 LOOP
  86                          A (I, J) := B;
  87                          B := B + 1;
  88                     END LOOP;
  89                END LOOP;
  90                RETURN A;
  91           END CREATE;
  92
  93      END PKG;
  94
  95 BEGIN
  96      TEST ("C34007I", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
  97                       "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
  98                       "WHEN THE DERIVED TYPE DEFINITION IS " &
  99                       "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
 100                       "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
 101                       "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
 102                       "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
 103                       "MULTI-DIMENSIONAL ARRAY TYPE");
 104
 105      -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
 106
 107      IF CREATE (6, 9, 2, 3, 1, X) . ALL /=
 108         ((1, 2), (3, 4), (5, 6), (7, 8)) OR
 109         CREATE (6, 9, 2, 3, 1, Y) . ALL /=
 110         ((1, 2), (3, 4), (5, 6), (7, 8)) THEN
 111           FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
 112      END IF;
 113
 114      IF CREATE (6, 9, 2, 3, 1, X) IN T OR
 115         CREATE (6, 9, 2, 3, 1, Y) IN S THEN
 116           FAILED ("INCORRECT ""IN""");
 117      END IF;
 118
 119      -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
 120
 121      IF X'FIRST /= 4 OR X'LAST /= 5 OR
 122         Y'FIRST /= 4 OR Y'LAST /= 5 OR
 123         X'FIRST (2) /= 6 OR X'LAST (2) /= 8 OR
 124         Y'FIRST (2) /= 6 OR Y'LAST (2) /= 8 THEN
 125           FAILED ("INCORRECT 'FIRST OR 'LAST");
 126      END IF;
 127
 128      BEGIN
 129           X := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
 130           Y := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
 131           IF PARENT (X) = PARENT (Y) OR  -- USE X AND Y.
 132              X.ALL /= Y.ALL THEN
 133                FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT");
 134           END IF;
 135      EXCEPTION
 136           WHEN OTHERS =>
 137                FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
 138      END;
 139
 140      BEGIN
 141           X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0));
 142           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 143                   "X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))");
 144           IF X = NULL OR ELSE
 145              X.ALL = ((0, 0, 0), (0, 0, 0)) THEN  -- USE X.
 146                COMMENT ("X ALTERED -- " &
 147                         "X := NEW DESIGNATED'(5 .. 6 => " &
 148                         "(6 .. 8 => 0))");
 149           END IF;
 150      EXCEPTION
 151           WHEN CONSTRAINT_ERROR =>
 152                NULL;
 153           WHEN OTHERS =>
 154                FAILED ("WRONG EXCEPTION RAISED -- " &
 155                        "X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))");
 156      END;
 157
 158      BEGIN
 159           X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0));
 160           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 161                   "X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))");
 162           IF X = NULL OR ELSE
 163              X.ALL = ((0, 0, 0), (0, 0, 0)) THEN  -- USE X.
 164                COMMENT ("X ALTERED -- " &
 165                         "X := NEW DESIGNATED'(4 .. 5 => " &
 166                         "(5 .. 7 => 0))");
 167           END IF;
 168      EXCEPTION
 169           WHEN CONSTRAINT_ERROR =>
 170                NULL;
 171           WHEN OTHERS =>
 172                FAILED ("WRONG EXCEPTION RAISED -- " &
 173                        "X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))");
 174      END;
 175
 176      BEGIN
 177           Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0));
 178           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 179                   "Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))");
 180           IF Y = NULL OR ELSE
 181              Y.ALL = ((0, 0, 0), (0, 0, 0)) THEN  -- USE Y.
 182                COMMENT ("Y ALTERED -- " &
 183                         "Y := NEW DESIGNATED'(5 .. 6 => " &
 184                         "(6 .. 8 => 0))");
 185           END IF;
 186      EXCEPTION
 187           WHEN CONSTRAINT_ERROR =>
 188                NULL;
 189           WHEN OTHERS =>
 190                FAILED ("WRONG EXCEPTION RAISED -- " &
 191                        "Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))");
 192      END;
 193
 194      BEGIN
 195           Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0));
 196           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 197                   "Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))");
 198           IF Y = NULL OR ELSE
 199              Y.ALL = ((0, 0, 0), (0, 0, 0)) THEN  -- USE Y.
 200                COMMENT ("Y ALTERED -- " &
 201                         "Y := NEW DESIGNATED'(4 .. 5 => " &
 202                         "(5 .. 7 => 0))");
 203           END IF;
 204      EXCEPTION
 205           WHEN CONSTRAINT_ERROR =>
 206                NULL;
 207           WHEN OTHERS =>
 208                FAILED ("WRONG EXCEPTION RAISED -- " &
 209                        "Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))");
 210      END;
 211
 212      RESULT;
 213 END C34007I;