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

   1 -- C38102E.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 -- CHECK THAT AN INCOMPLETE TYPE CAN BE REDECLARED AS A DERIVED GENERIC
  26 -- FORMAL TYPE.
  27
  28 -- AH     8/15/86
  29 -- PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  30 -- DNT 11/28/95  CHANGED TO FLAG1 := F4.
  31
  32 WITH REPORT; USE REPORT;
  33 PROCEDURE C38102E IS
  34      TYPE RAINBOW IS (RED, ORANGE, YELLOW, GREEN, BLUE, INDIGO, VIOLET);
  35      TYPE T_FLOAT IS DIGITS 5 RANGE -4.0 .. 4.0;
  36      TYPE T_FIXED IS DELTA 0.01 RANGE 0.0 .. 1.5;
  37      SUBTYPE P1 IS INTEGER;
  38      TYPE P2 IS RANGE 0 .. 10;
  39      TYPE P3 IS ARRAY (P2) OF INTEGER;
  40      TYPE P4 IS ARRAY (P2, P2) OF INTEGER;
  41
  42      F1, F2 : BOOLEAN;
  43
  44      GENERIC
  45           TYPE G1 IS (<>);
  46           TYPE G2 IS RANGE <>;
  47      FUNCTION G_DISCRETE RETURN BOOLEAN;
  48
  49      FUNCTION G_DISCRETE RETURN BOOLEAN IS
  50           TYPE INC1;
  51           TYPE INC2;
  52           TYPE F1 IS NEW G1;
  53           TYPE INC1 IS NEW G1;
  54           TYPE INC2 IS NEW G2;
  55
  56           OBJ1_0 : INC1;
  57           OBJ1_1 : INC1;
  58           OBJ2_0 : INC2;
  59           OBJ2_1 : INC2;
  60           OBJ3 : F1;
  61
  62           RESULT_VALUE1 : BOOLEAN := FALSE;
  63           RESULT_VALUE2 : BOOLEAN := FALSE;
  64      BEGIN
  65           OBJ3 := F1'LAST;
  66           OBJ3 := F1'PRED(OBJ3);
  67           IF INC1(OBJ3) = INC1'PRED(INC1'LAST) THEN
  68                RESULT_VALUE1 := TRUE;
  69           END IF;
  70           OBJ2_0 := INC2'FIRST;
  71           OBJ2_1 := INC2'LAST;
  72           IF (OBJ2_0 + OBJ2_1) = (INC2'SUCC(OBJ2_0) +
  73                                   INC2'PRED(OBJ2_1)) THEN
  74                RESULT_VALUE2 := TRUE;
  75           END IF;
  76
  77           RETURN (RESULT_VALUE1 AND RESULT_VALUE2);
  78      END G_DISCRETE;
  79
  80      GENERIC
  81           TYPE G3 IS DIGITS <>;
  82           TYPE G4 IS DELTA <>;
  83      PROCEDURE REALS (FLAG1, FLAG2 : OUT BOOLEAN);
  84
  85      PROCEDURE REALS (FLAG1, FLAG2 : OUT BOOLEAN) IS
  86           F1, F2, F3, F4, F5, F6, F7, F8 : BOOLEAN;
  87           TYPE INC3;
  88           TYPE INC4;
  89           TYPE P1 IS NEW G3;
  90           TYPE P2 IS NEW G4;
  91           TYPE INC3 IS NEW G3;
  92           TYPE INC4 IS NEW G4;
  93      BEGIN
  94           F4 := P1'LAST = P1(INC3'LAST) AND P1'FIRST = P1(INC3'FIRST);
  95
  96           F5 := P2'FORE = INC4'FORE;
  97           F6 := P2'AFT = INC4'AFT;
  98           F7 := ABS(P2'LAST - P2'FIRST) = P2(ABS(INC4'LAST -
  99                                                  INC4'FIRST));
 100           F8 := INC4(P2'LAST / P2'LAST) = INC4(INC4'LAST / INC4'LAST);
 101
 102           FLAG1 := F4;
 103           FLAG2 := F5 AND F6 AND F7 AND F8;
 104      END REALS;
 105
 106      GENERIC
 107           TYPE ITEM IS PRIVATE;
 108           TYPE INDEX IS RANGE <>;
 109           TYPE G5 IS ARRAY (INDEX) OF ITEM;
 110           TYPE G6 IS ARRAY (INDEX, INDEX) OF ITEM;
 111      PACKAGE DIMENSIONS IS
 112           TYPE INC5;
 113           TYPE INC6;
 114           TYPE D1 IS NEW G5;
 115           TYPE D2 IS NEW G6;
 116           TYPE INC5 IS NEW G5;
 117           TYPE INC6 IS NEW G6;
 118           FUNCTION CHECK RETURN BOOLEAN;
 119      END DIMENSIONS;
 120
 121      PACKAGE BODY DIMENSIONS IS
 122           FUNCTION CHECK RETURN BOOLEAN IS
 123                A1 : INC5;
 124                A2 : INC6;
 125                DIM1 : D1;
 126                DIM2 : D2;
 127                F1, F2 : BOOLEAN;
 128           BEGIN
 129                F1 := A1(INDEX'FIRST)'SIZE = DIM1(INDEX'FIRST)'SIZE;
 130                F2 := A2(INDEX'FIRST, INDEX'LAST)'SIZE =
 131                      DIM2(INDEX'FIRST, INDEX'LAST)'SIZE;
 132
 133                RETURN (F1 AND F2);
 134           END CHECK;
 135      END DIMENSIONS;
 136
 137      PROCEDURE PROC IS NEW REALS (G3 => T_FLOAT, G4 => T_FIXED);
 138      FUNCTION DISCRETE IS NEW G_DISCRETE (G1 => RAINBOW, G2 => P2);
 139      PACKAGE PKG IS NEW DIMENSIONS (ITEM => P1, INDEX => P2, G5 => P3,
 140                                     G6 => P4);
 141
 142      USE PKG;
 143 BEGIN
 144      TEST ("C38102E", "INCOMPLETE TYPES CAN BE DERIVED GENERIC " &
 145                       "FORMAL TYPES");
 146
 147      IF NOT DISCRETE THEN
 148           FAILED ("INTEGER AND ENUMERATED TYPES NOT DERIVED");
 149      END IF;
 150
 151      PROC (F1, F2);
 152      IF (NOT F1) THEN
 153           FAILED ("FLOAT TYPES NOT DERIVED");
 154      END IF;
 155      IF (NOT F2) THEN
 156           FAILED ("FIXED TYPES NOT DERIVED");
 157      END IF;
 158
 159      IF NOT CHECK THEN
 160           FAILED ("ONE AND TWO DIMENSIONAL ARRAY TYPES NOT DERIVED");
 161      END IF;
 162
 163      RESULT;
 164 END C38102E;