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

   1 -- C34009J.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 LIMITED PRIVATE TYPES WITH
  28 --     DISCRIMINANTS.
  29
  30 -- HISTORY:
  31 --     JRK 09/01/87  CREATED ORIGINAL TEST.
  32 --     WMC 03/13/92  REVISED TYPE'SIZE CHECKS.
  33 --     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  34
  35 WITH SYSTEM; USE SYSTEM;
  36 WITH REPORT; USE REPORT;
  37
  38 PROCEDURE C34009J IS
  39
  40      PACKAGE PKG IS
  41
  42           MAX_LEN : CONSTANT := 10;
  43
  44           SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
  45
  46           TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
  47                       LIMITED PRIVATE;
  48
  49           FUNCTION CREATE ( B : BOOLEAN;
  50                             L : LENGTH;
  51                             I : INTEGER;
  52                             S : STRING;
  53                             J : INTEGER;
  54                             F : FLOAT;
  55                             X : PARENT  -- TO RESOLVE OVERLOADING.
  56                           ) RETURN PARENT;
  57
  58           FUNCTION CON ( B : BOOLEAN;
  59                          L : LENGTH;
  60                          I : INTEGER;
  61                          S : STRING;
  62                          J : INTEGER
  63                        ) RETURN PARENT;
  64
  65           FUNCTION CON ( B : BOOLEAN;
  66                          L : LENGTH;
  67                          I : INTEGER;
  68                          F : FLOAT
  69                        ) RETURN PARENT;
  70
  71           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
  72
  73           PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT);
  74
  75      PRIVATE
  76
  77           TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
  78                RECORD
  79                     I : INTEGER := 2;
  80                     CASE B IS
  81                          WHEN TRUE =>
  82                               S : STRING (1 .. L) := (1 .. L => 'A');
  83                               J : INTEGER := 2;
  84                          WHEN FALSE =>
  85                               F : FLOAT := 5.0;
  86                     END CASE;
  87                END RECORD;
  88
  89      END PKG;
  90
  91      USE PKG;
  92
  93      TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
  94
  95      X : T;
  96      W : PARENT;
  97      B : BOOLEAN := FALSE;
  98
  99      PROCEDURE A (X : ADDRESS) IS
 100      BEGIN
 101           B := IDENT_BOOL (TRUE);
 102      END A;
 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 ("C34009J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
 162                       "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
 163                       "LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
 164
 165      IF EQUAL (3, 3) THEN
 166           ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4));
 167      END IF;
 168      IF NOT EQUAL (T'(X), CON (TRUE, 3, 1, "ABC", 4)) THEN
 169           FAILED ("INCORRECT QUALIFICATION");
 170      END IF;
 171
 172      IF NOT EQUAL (T (X), CON (TRUE, 3, 1, "ABC", 4)) THEN
 173           FAILED ("INCORRECT SELF CONVERSION");
 174      END IF;
 175
 176      IF EQUAL (3, 3) THEN
 177           ASSIGN (W, CON (TRUE, 3, 1, "ABC", 4));
 178      END IF;
 179      IF NOT EQUAL (T (W), CON (TRUE, 3, 1, "ABC", 4)) THEN
 180           FAILED ("INCORRECT CONVERSION FROM PARENT");
 181      END IF;
 182
 183      IF NOT EQUAL (PARENT (X), CON (TRUE, 3, 1, "ABC", 4)) OR
 184         NOT EQUAL (PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)),
 185                    CON (FALSE, 2, 3, 6.0)) THEN
 186           FAILED ("INCORRECT CONVERSION TO PARENT");
 187      END IF;
 188
 189      IF X.B /= TRUE OR X.L /= 3 OR
 190         CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
 191         CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
 192           FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
 193      END IF;
 194
 195      IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN
 196           FAILED ("INCORRECT ""IN""");
 197      END IF;
 198
 199      IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN
 200           FAILED ("INCORRECT ""NOT IN""");
 201      END IF;
 202
 203      B := FALSE;
 204      A (X'ADDRESS);
 205      IF NOT B THEN
 206           FAILED ("INCORRECT 'ADDRESS");
 207      END IF;
 208
 209
 210      IF NOT X'CONSTRAINED THEN
 211           FAILED ("INCORRECT OBJECT'CONSTRAINED");
 212      END IF;
 213
 214      IF T'SIZE <= 0 THEN
 215           FAILED ("INCORRECT TYPE'SIZE");
 216      END IF;
 217
 218      IF X'SIZE   < T'SIZE OR
 219         X.B'SIZE < BOOLEAN'SIZE OR
 220         X.L'SIZE < LENGTH'SIZE THEN
 221           FAILED ("INCORRECT OBJECT'SIZE");
 222      END IF;
 223
 224      RESULT;
 225 END C34009J;