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

   1 -- C34007S.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 ACCESS TYPES WHOSE DESIGNATED TYPE IS A
  28 --     PRIVATE TYPE WITH DISCRIMINANTS.
  29
  30 -- HISTORY:
  31 --     JRK 09/30/86  CREATED ORIGINAL TEST.
  32 --     BCB 10/21/87  CHANGED HEADER TO STANDARD FORMAT.  REVISED TEST SO
  33 --                   T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
  34 --     BCB 09/26/88  REMOVED COMPARISON INVOLVING OBJECT SIZE.
  35 --     BCB 03/07/90  PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
  36 --     THS 09/18/90  REMOVED DECLARATION OF B, MADE THE BODY OF
  37 --                   PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
  38 --     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  39
  40 WITH SYSTEM; USE SYSTEM;
  41 WITH REPORT; USE REPORT;
  42
  43 PROCEDURE C34007S IS
  44
  45      SUBTYPE COMPONENT IS INTEGER;
  46
  47      PACKAGE PKG_D IS
  48
  49           SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10;
  50
  51           TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
  52                           PRIVATE;
  53
  54           FUNCTION CREATE ( B : BOOLEAN;
  55                             L : LENGTH;
  56                             I : INTEGER;
  57                             S : STRING;
  58                             C : COMPONENT;
  59                             F : FLOAT
  60                           ) RETURN DESIGNATED;
  61
  62      PRIVATE
  63
  64           TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
  65                RECORD
  66                     I : INTEGER := 2;
  67                     CASE B IS
  68                          WHEN TRUE =>
  69                               S : STRING (1 .. L) := (1 .. L => 'A');
  70                               C : COMPONENT := 2;
  71                          WHEN FALSE =>
  72                               F : FLOAT := 5.0;
  73                     END CASE;
  74                END RECORD;
  75
  76      END PKG_D;
  77
  78      USE PKG_D;
  79
  80      SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_BOOL (TRUE),
  81                                           IDENT_INT (3));
  82
  83      PACKAGE PKG_P IS
  84
  85           TYPE PARENT IS ACCESS DESIGNATED;
  86
  87           FUNCTION CREATE ( B : BOOLEAN;
  88                             L : LENGTH;
  89                             I : INTEGER;
  90                             S : STRING;
  91                             C : COMPONENT;
  92                             F : FLOAT;
  93                             X : PARENT  -- TO RESOLVE OVERLOADING.
  94                           ) RETURN PARENT;
  95
  96      END PKG_P;
  97
  98      USE PKG_P;
  99
 100      TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
 101
 102      X : T       := NEW DESIGNATED (TRUE, 3);
 103      K : INTEGER := X'SIZE;
 104      Y : T       := NEW DESIGNATED (TRUE, 3);
 105      W : PARENT  := NEW DESIGNATED (TRUE, 3);
 106
 107      PROCEDURE A (X : ADDRESS) IS
 108      BEGIN
 109           NULL;
 110      END A;
 111
 112      PACKAGE BODY PKG_D IS
 113
 114           FUNCTION CREATE
 115              ( B : BOOLEAN;
 116                L : LENGTH;
 117                I : INTEGER;
 118                S : STRING;
 119                C : COMPONENT;
 120                F : FLOAT
 121              ) RETURN DESIGNATED
 122           IS
 123           BEGIN
 124                CASE B IS
 125                     WHEN TRUE =>
 126                          RETURN (TRUE, L, I, S, C);
 127                     WHEN FALSE =>
 128                          RETURN (FALSE, L, I, F);
 129                END CASE;
 130           END CREATE;
 131
 132      END PKG_D;
 133
 134      PACKAGE BODY PKG_P IS
 135
 136           FUNCTION CREATE
 137              ( B : BOOLEAN;
 138                L : LENGTH;
 139                I : INTEGER;
 140                S : STRING;
 141                C : COMPONENT;
 142                F : FLOAT;
 143                X : PARENT
 144              ) RETURN PARENT
 145           IS
 146           BEGIN
 147                RETURN NEW DESIGNATED'(CREATE (B, L, I, S, C, F));
 148           END CREATE;
 149
 150      END PKG_P;
 151
 152      FUNCTION IDENT (X : T) RETURN T IS
 153      BEGIN
 154           IF X = NULL OR ELSE EQUAL (X.L, X.L) THEN
 155                RETURN X;                          -- ALWAYS EXECUTED.
 156           END IF;
 157           RETURN NEW DESIGNATED'(CREATE (TRUE, 3, -1, "---", -1, -1.0));
 158      END IDENT;
 159
 160 BEGIN
 161      TEST ("C34007S", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
 162                       "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
 163                       "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
 164                       "PRIVATE TYPE WITH DISCRIMINANTS");
 165
 166      Y.ALL := CREATE (TRUE, 3, 1, "ABC", 4, 1.0);
 167      IF Y = NULL OR ELSE
 168         Y.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) THEN
 169           FAILED ("INCORRECT INITIALIZATION");
 170      END IF;
 171
 172      X := IDENT (Y);
 173      IF X /= Y THEN
 174           FAILED ("INCORRECT :=");
 175      END IF;
 176
 177      IF T'(X) /= Y THEN
 178           FAILED ("INCORRECT QUALIFICATION");
 179      END IF;
 180
 181      IF T (X) /= Y THEN
 182           FAILED ("INCORRECT SELF CONVERSION");
 183      END IF;
 184
 185      IF EQUAL (3, 3) THEN
 186           W := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0));
 187      END IF;
 188      X := T (W);
 189      IF X = NULL OR ELSE X = Y OR ELSE
 190         X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) THEN
 191           FAILED ("INCORRECT CONVERSION FROM PARENT");
 192      END IF;
 193
 194      X := IDENT (Y);
 195      W := PARENT (X);
 196      IF W = NULL OR ELSE
 197         W.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) OR ELSE
 198         T (W) /= Y THEN
 199           FAILED ("INCORRECT CONVERSION TO PARENT - 1");
 200      END IF;
 201
 202      W := PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X));
 203      IF W = NULL OR ELSE
 204         W.ALL /= CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN
 205           FAILED ("INCORRECT CONVERSION TO PARENT - 2");
 206      END IF;
 207
 208      IF IDENT (NULL) /= NULL OR X = NULL THEN
 209           FAILED ("INCORRECT NULL");
 210      END IF;
 211
 212      X := IDENT (NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)));
 213      IF (X = NULL OR ELSE X = Y OR ELSE
 214          X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0)) OR
 215         X = NEW DESIGNATED'(CREATE (FALSE, 3, 1, "XXX", 5, 4.0)) THEN
 216           FAILED ("INCORRECT ALLOCATOR");
 217      END IF;
 218
 219      X := IDENT (Y);
 220      IF X.B /= TRUE OR X.L /= 3 OR
 221         CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
 222         CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
 223           FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
 224      END IF;
 225
 226      IF X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) OR
 227         CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL /=
 228         CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN
 229           FAILED ("INCORRECT .ALL (VALUE)");
 230      END IF;
 231
 232      X.ALL := CREATE (TRUE, 3, 10, "ZZZ", 15, 1.0);
 233      IF X /= Y OR Y.ALL /= CREATE (TRUE, 3, 10, "ZZZ", 15, 2.0) THEN
 234           FAILED ("INCORRECT .ALL (ASSIGNMENT)");
 235      END IF;
 236
 237      Y.ALL := CREATE (TRUE, 3, 1, "ABC", 4, 1.0);
 238      BEGIN
 239           CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL :=
 240                CREATE (FALSE, 2, 10, "ZZ", 7, 15.0);
 241      EXCEPTION
 242           WHEN OTHERS =>
 243                FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)");
 244      END;
 245
 246      X := IDENT (NULL);
 247      BEGIN
 248           IF X.ALL = CREATE (FALSE, 0, 0, "", 0, 0.0) THEN
 249                FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
 250           ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
 251           END IF;
 252      EXCEPTION
 253           WHEN CONSTRAINT_ERROR =>
 254                NULL;
 255           WHEN OTHERS =>
 256                FAILED ("WRONG EXCEPTION FOR NULL.ALL");
 257      END;
 258
 259      X := IDENT (Y);
 260      IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR
 261         X = CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) THEN
 262           FAILED ("INCORRECT =");
 263      END IF;
 264
 265      IF X /= Y OR NOT (X /= NULL) OR
 266         NOT (X /= CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) THEN
 267           FAILED ("INCORRECT /=");
 268      END IF;
 269
 270      IF NOT (X IN T) OR CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) IN T THEN
 271           FAILED ("INCORRECT ""IN""");
 272      END IF;
 273
 274      IF X NOT IN T OR
 275         NOT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) NOT IN T) THEN
 276           FAILED ("INCORRECT ""NOT IN""");
 277      END IF;
 278
 279      A (X'ADDRESS);
 280
 281      IF T'SIZE < 1 THEN
 282           FAILED ("INCORRECT TYPE'SIZE");
 283      END IF;
 284
 285      BEGIN
 286           IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
 287                FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
 288                        "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
 289           END IF;
 290      EXCEPTION
 291           WHEN PROGRAM_ERROR =>
 292                COMMENT ("PROGRAM_ERROR RAISED FOR " &
 293                         "UNDEFINED STORAGE_SIZE (AI-00608)");
 294           WHEN OTHERS =>
 295                FAILED ("UNEXPECTED EXCEPTION RAISED");
 296      END;
 297
 298      RESULT;
 299 END C34007S;