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

   1 -- C34007F.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 ONE-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 C34007F IS
  40
  41      SUBTYPE COMPONENT IS INTEGER;
  42
  43      TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT;
  44
  45      SUBTYPE SUBDESIGNATED IS DESIGNATED (5 .. 7);
  46
  47      PACKAGE PKG IS
  48
  49           TYPE PARENT IS ACCESS DESIGNATED;
  50
  51           FUNCTION CREATE ( F, L  : NATURAL;
  52                             C     : COMPONENT;
  53                             DUMMY : PARENT   -- TO RESOLVE OVERLOADING.
  54                           ) RETURN PARENT;
  55
  56      END PKG;
  57
  58      USE PKG;
  59
  60      TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
  61
  62      SUBTYPE SUBPARENT IS PARENT (5 .. 7);
  63
  64      TYPE S IS NEW SUBPARENT;
  65
  66      X : T := NEW SUBDESIGNATED'(OTHERS => 2);
  67      Y : S := NEW SUBDESIGNATED'(OTHERS => 2);
  68
  69      PACKAGE BODY PKG IS
  70
  71           FUNCTION CREATE
  72              ( F, L  : NATURAL;
  73                C     : COMPONENT;
  74                DUMMY : PARENT
  75              ) RETURN PARENT
  76           IS
  77                A : PARENT    := NEW DESIGNATED (F .. L);
  78                B : COMPONENT := C;
  79           BEGIN
  80                FOR I IN F .. L LOOP
  81                     A (I) := B;
  82                     B := B + 1;
  83                END LOOP;
  84                RETURN A;
  85           END CREATE;
  86
  87      END PKG;
  88
  89 BEGIN
  90      TEST ("C34007F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
  91                       "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
  92                       "WHEN THE DERIVED TYPE DEFINITION IS " &
  93                       "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
  94                       "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
  95                       "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
  96                       "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
  97                       "ONE-DIMENSIONAL ARRAY TYPE");
  98
  99      -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
 100
 101      IF CREATE (2, 3, 4, X) . ALL /= (4, 5) OR
 102         CREATE (2, 3, 4, Y) . ALL /= (4, 5) THEN
 103           FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
 104      END IF;
 105
 106      IF CREATE (2, 3, 4, X) IN T OR
 107         CREATE (2, 3, 4, Y) IN S THEN
 108           FAILED ("INCORRECT ""IN""");
 109      END IF;
 110
 111      -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
 112
 113      IF X'FIRST /= 5 OR X'LAST /= 7 OR
 114         Y'FIRST /= 5 OR Y'LAST /= 7 THEN
 115           FAILED ("INCORRECT 'FIRST OR 'LAST");
 116      END IF;
 117
 118      BEGIN
 119           X := NEW SUBDESIGNATED'(1, 2, 3);
 120           Y := NEW SUBDESIGNATED'(1, 2, 3);
 121           IF PARENT (X) = PARENT (Y) OR  -- USE X AND Y.
 122              X.ALL /= Y.ALL THEN
 123                FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT");
 124           END IF;
 125      EXCEPTION
 126           WHEN OTHERS =>
 127                FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
 128      END;
 129
 130      BEGIN
 131           X := NEW DESIGNATED'(6 .. 8 => 0);
 132           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 133                   "X := NEW DESIGNATED'(6 .. 8 => 0)");
 134           IF X = NULL OR ELSE X.ALL = (0, 0, 0) THEN  -- USE X.
 135                COMMENT ("X ALTERED -- " &
 136                         "X := NEW DESIGNATED'(6 .. 8 => 0)");
 137           END IF;
 138      EXCEPTION
 139           WHEN CONSTRAINT_ERROR =>
 140                NULL;
 141           WHEN OTHERS =>
 142                FAILED ("WRONG EXCEPTION RAISED -- " &
 143                        "X := NEW DESIGNATED'(6 .. 8 => 0)");
 144      END;
 145
 146      BEGIN
 147           Y := NEW DESIGNATED'(6 .. 8 => 0);
 148           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 149                   "Y := NEW DESIGNATED'(6 .. 8 => 0)");
 150           IF Y = NULL OR ELSE Y.ALL = (0, 0, 0) THEN  -- USE Y.
 151                COMMENT ("Y ALTERED -- " &
 152                         "Y := NEW DESIGNATED'(6 .. 8 => 0)");
 153           END IF;
 154      EXCEPTION
 155           WHEN CONSTRAINT_ERROR =>
 156                NULL;
 157           WHEN OTHERS =>
 158                FAILED ("WRONG EXCEPTION RAISED -- " &
 159                        "Y := NEW DESIGNATED'(6 .. 8 => 0)");
 160      END;
 161
 162      RESULT;
 163 END C34007F;