old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c34005f.ada

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