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

   1 -- C34006J.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 --     CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
  27 --     (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH
  28 --     A LIMITED COMPONENT TYPE.
  29
  30 -- HISTORY:
  31 --     JRK 08/25/87  CREATED ORIGINAL TEST.
  32 --     VCL 06/28/88  MODIFIED THE STATEMENTS INVOLVING THE 'SIZE
  33 --                   ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE
  34 --                   SIZES.
  35 --     PWN 11/30/94  REMOVED 'BASE USE ILLEGAL IN ADA 9X.
  36
  37 WITH SYSTEM; USE SYSTEM;
  38 WITH REPORT; USE REPORT;
  39
  40 PROCEDURE C34006J IS
  41
  42      PACKAGE PKG_L IS
  43
  44           TYPE LP IS LIMITED PRIVATE;
  45
  46           FUNCTION CREATE (X : INTEGER) RETURN LP;
  47
  48           FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
  49
  50           PROCEDURE ASSIGN (X : OUT LP; Y : LP);
  51
  52           C4 : CONSTANT LP;
  53           C5 : CONSTANT LP;
  54
  55      PRIVATE
  56
  57           TYPE LP IS NEW INTEGER;
  58
  59           C4 : CONSTANT LP := 4;
  60           C5 : CONSTANT LP := 5;
  61
  62      END PKG_L;
  63
  64      USE PKG_L;
  65
  66      SUBTYPE COMPONENT IS LP;
  67
  68      PACKAGE PKG_P IS
  69
  70           MAX_LEN : CONSTANT := 10;
  71
  72           SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
  73
  74           TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
  75                RECORD
  76                     I : INTEGER := 2;
  77                     CASE B IS
  78                          WHEN TRUE =>
  79                               S : STRING (1 .. L) := (1 .. L => 'A');
  80                               C : COMPONENT;
  81                          WHEN FALSE =>
  82                               F : FLOAT := 5.0;
  83                     END CASE;
  84                END RECORD;
  85
  86           FUNCTION CREATE ( B : BOOLEAN;
  87                             L : LENGTH;
  88                             I : INTEGER;
  89                             S : STRING;
  90                             C : COMPONENT;
  91                             F : FLOAT;
  92                             X : PARENT  -- TO RESOLVE OVERLOADING.
  93                           ) RETURN PARENT;
  94
  95           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
  96
  97           FUNCTION AGGR ( B : BOOLEAN;
  98                           L : LENGTH;
  99                           I : INTEGER;
 100                           S : STRING;
 101                           C : COMPONENT
 102                         ) RETURN PARENT;
 103
 104           FUNCTION AGGR ( B : BOOLEAN;
 105                           L : LENGTH;
 106                           I : INTEGER;
 107                           F : FLOAT
 108                         ) RETURN PARENT;
 109
 110      END PKG_P;
 111
 112      USE PKG_P;
 113
 114      TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
 115
 116      X : T;
 117      W : PARENT;
 118      B : BOOLEAN := FALSE;
 119
 120      PROCEDURE A (X : ADDRESS) IS
 121      BEGIN
 122           B := IDENT_BOOL (TRUE);
 123      END A;
 124
 125      PACKAGE BODY PKG_L IS
 126
 127           FUNCTION CREATE (X : INTEGER) RETURN LP IS
 128           BEGIN
 129                RETURN LP (IDENT_INT (X));
 130           END CREATE;
 131
 132           FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
 133           BEGIN
 134                RETURN X = Y;
 135           END EQUAL;
 136
 137           PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
 138           BEGIN
 139                X := Y;
 140           END ASSIGN;
 141
 142      END PKG_L;
 143
 144      PACKAGE BODY PKG_P IS
 145
 146           FUNCTION CREATE
 147              ( B : BOOLEAN;
 148                L : LENGTH;
 149                I : INTEGER;
 150                S : STRING;
 151                C : COMPONENT;
 152                F : FLOAT;
 153                X : PARENT
 154              ) RETURN PARENT
 155           IS
 156                A : PARENT (B, L);
 157           BEGIN
 158                A.I := I;
 159                CASE B IS
 160                     WHEN TRUE =>
 161                          A.S := S;
 162                          ASSIGN (A.C, C);
 163                     WHEN FALSE =>
 164                          A.F := F;
 165                END CASE;
 166                RETURN A;
 167           END CREATE;
 168
 169           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
 170           BEGIN
 171                IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN
 172                     RETURN FALSE;
 173                END IF;
 174                CASE X.B IS
 175                     WHEN TRUE =>
 176                          RETURN X.S = Y.S AND EQUAL (X.C, Y.C);
 177                     WHEN FALSE =>
 178                          RETURN X.F = Y.F;
 179                END CASE;
 180           END EQUAL;
 181
 182           FUNCTION AGGR
 183              ( B : BOOLEAN;
 184                L : LENGTH;
 185                I : INTEGER;
 186                S : STRING;
 187                C : COMPONENT
 188              ) RETURN PARENT
 189           IS
 190                RESULT : PARENT (B, L);
 191           BEGIN
 192                RESULT.I := I;
 193                RESULT.S := S;
 194                ASSIGN (RESULT.C, C);
 195                RETURN RESULT;
 196           END AGGR;
 197
 198           FUNCTION AGGR
 199              ( B : BOOLEAN;
 200                L : LENGTH;
 201                I : INTEGER;
 202                F : FLOAT
 203              ) RETURN PARENT
 204           IS
 205                RESULT : PARENT (B, L);
 206           BEGIN
 207                RESULT.I := I;
 208                RESULT.F := F;
 209                RETURN RESULT;
 210           END AGGR;
 211
 212      END PKG_P;
 213
 214 BEGIN
 215      TEST ("C34006J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
 216                       "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
 217                       "RECORD TYPES WITH DISCRIMINANTS AND WITH A " &
 218                       "LIMITED COMPONENT TYPE");
 219
 220      X.I := IDENT_INT (1);
 221      X.S := IDENT_STR ("ABC");
 222      ASSIGN (X.C, CREATE (4));
 223
 224      W.I := IDENT_INT (1);
 225      W.S := IDENT_STR ("ABC");
 226      ASSIGN (W.C, CREATE (4));
 227
 228      IF NOT EQUAL (T'(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
 229           FAILED ("INCORRECT QUALIFICATION");
 230      END IF;
 231
 232      IF NOT EQUAL (T(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
 233           FAILED ("INCORRECT SELF CONVERSION");
 234      END IF;
 235
 236      IF NOT EQUAL (T(W), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
 237           FAILED ("INCORRECT CONVERSION FROM PARENT");
 238      END IF;
 239
 240      IF NOT EQUAL (PARENT(X), AGGR (TRUE, 3, 1, "ABC", C4))   OR
 241         NOT EQUAL (PARENT(CREATE (FALSE, 2, 3, "XX", C5, 6.0, X)),
 242                    AGGR (FALSE, 2, 3, 6.0))   THEN
 243           FAILED ("INCORRECT CONVERSION TO PARENT");
 244      END IF;
 245
 246      IF X.B /= TRUE OR X.L /= 3 OR
 247         CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).B /= FALSE OR
 248         CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).L /= 2 THEN
 249           FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
 250      END IF;
 251
 252      IF X.I /= 1 OR X.S /= "ABC" OR NOT EQUAL (X.C, C4) OR
 253         CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).I /= 3 OR
 254         CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).F /= 6.0 THEN
 255           FAILED ("INCORRECT SELECTION (VALUE)");
 256      END IF;
 257
 258      X.I := IDENT_INT (7);
 259      X.S := IDENT_STR ("XYZ");
 260      IF NOT EQUAL (X, AGGR (TRUE, 3, 7, "XYZ", C4)) THEN
 261           FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
 262      END IF;
 263
 264      X.I := IDENT_INT (1);
 265      X.S := IDENT_STR ("ABC");
 266      IF NOT (X IN T) OR AGGR (FALSE, 2, 3, 6.0) IN T THEN
 267           FAILED ("INCORRECT ""IN""");
 268      END IF;
 269
 270      IF X NOT IN T OR NOT (AGGR (FALSE, 2, 3, 6.0) NOT IN T) THEN
 271           FAILED ("INCORRECT ""NOT IN""");
 272      END IF;
 273
 274      B := FALSE;
 275      A (X'ADDRESS);
 276      IF NOT B THEN
 277           FAILED ("INCORRECT 'ADDRESS");
 278      END IF;
 279
 280      IF NOT X'CONSTRAINED THEN
 281           FAILED ("INCORRECT 'CONSTRAINED");
 282      END IF;
 283
 284      IF X.C'FIRST_BIT < 0 THEN
 285           FAILED ("INCORRECT 'FIRST_BIT");
 286      END IF;
 287
 288      IF X.C'LAST_BIT < 0 OR
 289         X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
 290           FAILED ("INCORRECT 'LAST_BIT");
 291      END IF;
 292
 293      IF X.C'POSITION < 0 THEN
 294           FAILED ("INCORRECT 'POSITION");
 295      END IF;
 296
 297      IF X'SIZE < T'SIZE THEN
 298           COMMENT ("X'SIZE < T'SIZE");
 299      ELSIF X'SIZE = T'SIZE THEN
 300           COMMENT ("X'SIZE = T'SIZE");
 301      ELSE
 302           COMMENT ("X'SIZE > T'SIZE");
 303      END IF;
 304
 305      RESULT;
 306 EXCEPTION
 307      WHEN OTHERS =>
 308           FAILED ("UNEXPECTED EXCEPTION RAISED WHILE CHECKING BASIC " &
 309                   "OPERATIONS");
 310           RESULT;
 311 END C34006J;