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

   1 -- C34009L.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 LIMITED PRIVATE TYPES WITH DISCRIMINANTS:
  27
  28 --        CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
  29 --        FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
  30 --        IS CONSTRAINED.
  31
  32 --        CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
  33 --        ALSO IMPOSED ON THE DERIVED SUBTYPE.
  34
  35 -- HISTORY:
  36 --     JRK 09/01/87  CREATED ORIGINAL TEST.
  37
  38 WITH REPORT; USE REPORT;
  39
  40 PROCEDURE C34009L IS
  41
  42      PACKAGE PKG IS
  43
  44           MAX_LEN : CONSTANT := 10;
  45
  46           SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
  47
  48           TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
  49                       LIMITED PRIVATE;
  50
  51           FUNCTION CREATE ( B : BOOLEAN;
  52                             L : LENGTH;
  53                             I : INTEGER;
  54                             S : STRING;
  55                             J : INTEGER;
  56                             F : FLOAT;
  57                             X : PARENT  -- TO RESOLVE OVERLOADING.
  58                           ) RETURN PARENT;
  59
  60           FUNCTION CON ( B : BOOLEAN;
  61                          L : LENGTH;
  62                          I : INTEGER;
  63                          S : STRING;
  64                          J : INTEGER
  65                        ) RETURN PARENT;
  66
  67           FUNCTION CON ( B : BOOLEAN;
  68                          L : LENGTH;
  69                          I : INTEGER;
  70                          F : FLOAT
  71                        ) RETURN PARENT;
  72
  73           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
  74
  75           PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT);
  76
  77      PRIVATE
  78
  79           TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
  80                RECORD
  81                     I : INTEGER := 2;
  82                     CASE B IS
  83                          WHEN TRUE =>
  84                               S : STRING (1 .. L) := (1 .. L => 'A');
  85                               J : INTEGER := 2;
  86                          WHEN FALSE =>
  87                               F : FLOAT := 5.0;
  88                     END CASE;
  89                END RECORD;
  90
  91      END PKG;
  92
  93      USE PKG;
  94
  95      TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
  96
  97      SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
  98
  99      TYPE S IS NEW SUBPARENT;
 100
 101      X : T;
 102      Y : S;
 103
 104      PACKAGE BODY PKG IS
 105
 106           FUNCTION CREATE
 107              ( B : BOOLEAN;
 108                L : LENGTH;
 109                I : INTEGER;
 110                S : STRING;
 111                J : INTEGER;
 112                F : FLOAT;
 113                X : PARENT
 114              ) RETURN PARENT
 115           IS
 116           BEGIN
 117                CASE B IS
 118                     WHEN TRUE =>
 119                          RETURN (TRUE, L, I, S, J);
 120                     WHEN FALSE =>
 121                          RETURN (FALSE, L, I, F);
 122                END CASE;
 123           END CREATE;
 124
 125           FUNCTION CON
 126              ( B : BOOLEAN;
 127                L : LENGTH;
 128                I : INTEGER;
 129                S : STRING;
 130                J : INTEGER
 131              ) RETURN PARENT
 132           IS
 133           BEGIN
 134                RETURN (TRUE, L, I, S, J);
 135           END CON;
 136
 137           FUNCTION CON
 138              ( B : BOOLEAN;
 139                L : LENGTH;
 140                I : INTEGER;
 141                F : FLOAT
 142              ) RETURN PARENT
 143           IS
 144           BEGIN
 145                RETURN (FALSE, L, I, F);
 146           END CON;
 147
 148           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
 149           BEGIN
 150                RETURN X = Y;
 151           END EQUAL;
 152
 153           PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS
 154           BEGIN
 155                X := Y;
 156           END ASSIGN;
 157
 158      END PKG;
 159
 160 BEGIN
 161      TEST ("C34009L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
 162                       "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
 163                       "WHEN THE DERIVED TYPE DEFINITION IS " &
 164                       "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
 165                       "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
 166                       "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
 167                       "LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
 168
 169      -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
 170
 171      IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X),
 172                    CON (FALSE, 2, 3, 6.0)) OR
 173         NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y),
 174                    CON (FALSE, 2, 3, 6.0)) THEN
 175           FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
 176      END IF;
 177
 178      IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
 179         CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
 180           FAILED ("INCORRECT ""IN""");
 181      END IF;
 182
 183      -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
 184
 185      IF X.B /= TRUE OR X.L /= 3 OR
 186         Y.B /= TRUE OR Y.L /= 3 THEN
 187           FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
 188      END IF;
 189
 190      IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
 191           FAILED ("INCORRECT 'CONSTRAINED");
 192      END IF;
 193
 194      BEGIN
 195           ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4));
 196           ASSIGN (Y, CON (TRUE, 3, 1, "ABC", 4));
 197           IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN  -- USE X AND Y.
 198                FAILED ("INCORRECT CONVERSION TO PARENT");
 199           END IF;
 200      EXCEPTION
 201           WHEN OTHERS =>
 202                FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
 203      END;
 204
 205      BEGIN
 206           ASSIGN (X, CON (FALSE, 3, 2, 6.0));
 207           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 208                   "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
 209           IF EQUAL (X, CON (FALSE, 3, 2, 6.0)) THEN  -- USE X.
 210                COMMENT ("X ALTERED -- " &
 211                         "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
 212           END IF;
 213      EXCEPTION
 214           WHEN CONSTRAINT_ERROR =>
 215                NULL;
 216           WHEN OTHERS =>
 217                FAILED ("WRONG EXCEPTION RAISED -- " &
 218                        "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
 219      END;
 220
 221      BEGIN
 222           ASSIGN (X, CON (TRUE, 4, 2, "ZZZZ", 6));
 223           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 224                   "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
 225           IF EQUAL (X, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN  -- USE X.
 226                COMMENT ("X ALTERED -- " &
 227                         "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
 228           END IF;
 229      EXCEPTION
 230           WHEN CONSTRAINT_ERROR =>
 231                NULL;
 232           WHEN OTHERS =>
 233                FAILED ("WRONG EXCEPTION RAISED -- " &
 234                        "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
 235      END;
 236
 237      BEGIN
 238           ASSIGN (Y, CON (FALSE, 3, 2, 6.0));
 239           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 240                   "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
 241           IF EQUAL (Y, CON (FALSE, 3, 2, 6.0)) THEN  -- USE Y.
 242                COMMENT ("Y ALTERED -- " &
 243                         "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
 244           END IF;
 245      EXCEPTION
 246           WHEN CONSTRAINT_ERROR =>
 247                NULL;
 248           WHEN OTHERS =>
 249                FAILED ("WRONG EXCEPTION RAISED -- " &
 250                        "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
 251      END;
 252
 253      BEGIN
 254           ASSIGN (Y, CON (TRUE, 4, 2, "ZZZZ", 6));
 255           FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
 256                   "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
 257           IF EQUAL (Y, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN  -- USE Y.
 258                COMMENT ("Y ALTERED -- " &
 259                         "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
 260           END IF;
 261      EXCEPTION
 262           WHEN CONSTRAINT_ERROR =>
 263                NULL;
 264           WHEN OTHERS =>
 265                FAILED ("WRONG EXCEPTION RAISED -- " &
 266                        "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
 267      END;
 268
 269      RESULT;
 270 END C34009L;