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

   1 -- C34006D.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 --     NON-LIMITED COMPONENT TYPES.
  29
  30 -- HISTORY:
  31 --     JRK 09/22/86  CREATED ORIGINAL TEST.
  32 --     BCB 11/13/87  CHANGED TEST SO AN OBJECT'S SIZE MAY BE LESS THAN
  33 --                   THAT OF ITS TYPE.
  34 --     RJW 08/21/89  MODIFIED CHECKS FOR SIZE.
  35 --     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  36
  37 WITH SYSTEM; USE SYSTEM;
  38 WITH REPORT; USE REPORT;
  39
  40 PROCEDURE C34006D IS
  41
  42      SUBTYPE COMPONENT IS INTEGER;
  43
  44      PACKAGE PKG IS
  45
  46           MAX_LEN : CONSTANT := 10;
  47
  48           SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
  49
  50           TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
  51                RECORD
  52                     I : INTEGER;
  53                     CASE B IS
  54                          WHEN TRUE =>
  55                               S : STRING (1 .. L);
  56                               C : COMPONENT;
  57                          WHEN FALSE =>
  58                               F : FLOAT := 5.0;
  59                     END CASE;
  60                END RECORD;
  61
  62           FUNCTION CREATE ( B : BOOLEAN;
  63                             L : LENGTH;
  64                             I : INTEGER;
  65                             S : STRING;
  66                             C : COMPONENT;
  67                             F : FLOAT;
  68                             X : PARENT  -- TO RESOLVE OVERLOADING.
  69                           ) RETURN PARENT;
  70
  71      END PKG;
  72
  73      USE PKG;
  74
  75      TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
  76
  77      X : T         := (TRUE, 3, 2, "AAA", 2);
  78      W : PARENT    := (TRUE, 3, 2, "AAA", 2);
  79      C : COMPONENT := 1;
  80      B : BOOLEAN   := FALSE;
  81
  82      PROCEDURE A (X : ADDRESS) IS
  83      BEGIN
  84           B := IDENT_BOOL (TRUE);
  85      END A;
  86
  87      PACKAGE BODY PKG IS
  88
  89           FUNCTION CREATE
  90              ( B : BOOLEAN;
  91                L : LENGTH;
  92                I : INTEGER;
  93                S : STRING;
  94                C : COMPONENT;
  95                F : FLOAT;
  96                X : PARENT
  97              ) RETURN PARENT
  98           IS
  99           BEGIN
 100                CASE B IS
 101                     WHEN TRUE =>
 102                          RETURN (TRUE, L, I, S, C);
 103                     WHEN FALSE =>
 104                          RETURN (FALSE, L, I, F);
 105                END CASE;
 106           END CREATE;
 107
 108      END PKG;
 109
 110      FUNCTION IDENT (X : T) RETURN T IS
 111      BEGIN
 112           IF EQUAL (X.I, X.I) THEN
 113                RETURN X;                          -- ALWAYS EXECUTED.
 114           END IF;
 115           RETURN (TRUE, 3, -1, "---", -1);
 116      END IDENT;
 117
 118 BEGIN
 119      TEST ("C34006D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
 120                       "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
 121                       "RECORD TYPES WITH DISCRIMINANTS AND WITH " &
 122                       "NON-LIMITED COMPONENT TYPES");
 123
 124      X := IDENT ((TRUE, 3, 1, "ABC", 4));
 125      IF X /= (TRUE, 3, 1, "ABC", 4) THEN
 126           FAILED ("INCORRECT :=");
 127      END IF;
 128
 129      IF T'(X) /= (TRUE, 3, 1, "ABC", 4) THEN
 130           FAILED ("INCORRECT QUALIFICATION");
 131      END IF;
 132
 133      IF T (X) /= (TRUE, 3, 1, "ABC", 4) THEN
 134           FAILED ("INCORRECT SELF CONVERSION");
 135      END IF;
 136
 137      IF EQUAL (3, 3) THEN
 138           W := (TRUE, 3, 1, "ABC", 4);
 139      END IF;
 140      IF T (W) /= (TRUE, 3, 1, "ABC", 4) THEN
 141           FAILED ("INCORRECT CONVERSION FROM PARENT");
 142      END IF;
 143
 144      BEGIN
 145           IF PARENT (X) /= (TRUE, 3, 1, "ABC", 4) OR
 146              PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) /=
 147              (FALSE, 2, 3, 6.0) THEN
 148                FAILED ("INCORRECT CONVERSION TO PARENT");
 149           END IF;
 150      EXCEPTION
 151           WHEN CONSTRAINT_ERROR =>
 152                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
 153           WHEN OTHERS =>
 154                FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
 155      END;
 156
 157      IF IDENT ((TRUE, 3, 1, "ABC", 4)) /= (TRUE, 3, 1, "ABC", 4) OR
 158         X = (FALSE, 3, 1, 4.0) THEN
 159           FAILED ("INCORRECT AGGREGATE");
 160      END IF;
 161
 162      BEGIN
 163           IF X.B /= TRUE OR X.L /= 3 OR
 164              CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
 165              CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
 166                FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
 167           END IF;
 168      EXCEPTION
 169           WHEN CONSTRAINT_ERROR =>
 170                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
 171           WHEN OTHERS =>
 172                FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
 173      END;
 174
 175      BEGIN
 176           IF X.I /= 1 OR X.S /= "ABC" OR X.C /= 4 OR
 177              CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I /= 3 OR
 178              CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F /= 6.0 THEN
 179                FAILED ("INCORRECT SELECTION (VALUE)");
 180           END IF;
 181      EXCEPTION
 182           WHEN CONSTRAINT_ERROR =>
 183                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3");
 184           WHEN OTHERS =>
 185                FAILED ("CALL TO CREATE RAISED EXCEPTION - 3");
 186      END;
 187
 188      X.I := IDENT_INT (7);
 189      X.S := IDENT_STR ("XYZ");
 190      X.C := IDENT_INT (9);
 191      IF X /= (TRUE, 3, 7, "XYZ", 9) THEN
 192           FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
 193      END IF;
 194
 195      X := IDENT ((TRUE, 3, 1, "ABC", 4));
 196      IF X = IDENT ((TRUE, 3, 1, "ABC", 5)) OR
 197         X = (FALSE, 2, 3, 6.0) THEN
 198           FAILED ("INCORRECT =");
 199      END IF;
 200
 201      IF X /= IDENT ((TRUE, 3, 1, "ABC", 4)) OR
 202         NOT (X /= (FALSE, 2, 3, 6.0)) THEN
 203           FAILED ("INCORRECT /=");
 204      END IF;
 205
 206      IF NOT (X IN T) OR (FALSE, 2, 3, 6.0) IN T THEN
 207           FAILED ("INCORRECT ""IN""");
 208      END IF;
 209
 210      IF X NOT IN T OR NOT ((FALSE, 2, 3, 6.0) NOT IN T) THEN
 211           FAILED ("INCORRECT ""NOT IN""");
 212      END IF;
 213
 214      B := FALSE;
 215      A (X'ADDRESS);
 216      IF NOT B THEN
 217           FAILED ("INCORRECT 'ADDRESS");
 218      END IF;
 219
 220      IF NOT X'CONSTRAINED THEN
 221           FAILED ("INCORRECT 'CONSTRAINED");
 222      END IF;
 223
 224      IF X.C'FIRST_BIT < 0 THEN
 225           FAILED ("INCORRECT 'FIRST_BIT");
 226      END IF;
 227
 228      IF X.C'LAST_BIT < 0 OR
 229         X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
 230           FAILED ("INCORRECT 'LAST_BIT");
 231      END IF;
 232
 233      IF X.C'POSITION < 0 THEN
 234           FAILED ("INCORRECT 'POSITION");
 235      END IF;
 236
 237      RESULT;
 238 END C34006D;