gcc/testsuite/ada/acats/tests/cc/cc3233a.ada

   1 -- CC3233A.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 A PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS
  27 --     ACTUAL PARAMETER, A FIXED POINT TYPE AND OPERATIONS OF THE FORMAL
  28 --     TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL
  29 --     TYPE.
  30
  31 -- HISTORY:
  32 --     TBN 09/15/88  CREATED ORIGINAL TEST.
  33 --     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  34
  35 WITH REPORT; USE REPORT;
  36 PROCEDURE CC3233A IS
  37
  38      TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0;
  39
  40      GENERIC
  41           TYPE T IS PRIVATE;
  42      PACKAGE P IS
  43           SUBTYPE SUB_T IS T;
  44           PAC_VAR : T;
  45      END P;
  46
  47      GENERIC
  48           TYPE T IS LIMITED PRIVATE;
  49      PACKAGE LP IS
  50           SUBTYPE SUB_T IS T;
  51           PAC_VAR : T;
  52      END LP;
  53
  54      FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS
  55      BEGIN
  56           IF EQUAL (3, 3) THEN
  57                RETURN X;
  58           ELSE
  59                RETURN (0.0);
  60           END IF;
  61      END IDENT_FIX;
  62
  63 BEGIN
  64      TEST ("CC3233A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " &
  65                       "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, A " &
  66                       "FIXED POINT TYPE AND OPERATIONS OF THE FORMAL " &
  67                       "TYPE ARE IDENTIFIED WITH CORRESPONDING " &
  68                       "OPERATIONS OF THE ACTUAL TYPE");
  69
  70      DECLARE  -- PRIVATE TYPE.
  71           OBJ_INT : INTEGER := 1;
  72           OBJ_FIX : FIXED := 1.0;
  73
  74           PACKAGE P1 IS NEW P (FIXED);
  75           USE P1;
  76
  77           TYPE NEW_T IS NEW SUB_T;
  78           OBJ_NEWT : NEW_T;
  79      BEGIN
  80           PAC_VAR := SUB_T'(1.0);
  81           IF PAC_VAR /= OBJ_FIX THEN
  82                FAILED ("INCORRECT RESULTS - 1");
  83           END IF;
  84           OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX);
  85           IF OBJ_FIX <= PAC_VAR THEN
  86                FAILED ("INCORRECT RESULTS - 2");
  87           END IF;
  88           PAC_VAR := OBJ_INT * OBJ_FIX;
  89           IF PAC_VAR NOT IN FIXED THEN
  90                FAILED ("INCORRECT RESULTS - 3");
  91           END IF;
  92           IF OBJ_FIX NOT IN SUB_T THEN
  93                FAILED ("INCORRECT RESULTS - 4");
  94           END IF;
  95           IF SUB_T'DELTA /= 0.125 THEN
  96                FAILED ("INCORRECT RESULTS - 5");
  97           END IF;
  98           OBJ_NEWT := 1.0;
  99           OBJ_NEWT := OBJ_NEWT - 1.0;
 100           IF OBJ_NEWT NOT IN NEW_T THEN
 101                FAILED ("INCORRECT RESULTS - 6");
 102           END IF;
 103           IF NEW_T'DELTA /= 0.125 THEN
 104                FAILED ("INCORRECT RESULTS - 7");
 105           END IF;
 106           OBJ_NEWT := NEW_T'SMALL + 1.0;
 107           OBJ_FIX := 1.0;
 108           OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX);
 109           IF OBJ_FIX /= 1.0 THEN
 110                FAILED ("INCORRECT RESULTS - 8");
 111           END IF;
 112           OBJ_FIX := 1.0;
 113           OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX);
 114           IF OBJ_FIX /= 1.0 THEN
 115                FAILED ("INCORRECT RESULTS - 9");
 116           END IF;
 117           IF FIXED'SMALL /= NEW_T'SMALL THEN
 118                FAILED ("INCORRECT RESULTS - 10");
 119           END IF;
 120      END;
 121
 122      DECLARE  -- LIMITED PRIVATE TYPE.
 123           OBJ_INT : INTEGER := 1;
 124           OBJ_FIX : FIXED := 1.0;
 125
 126           PACKAGE P1 IS NEW LP (FIXED);
 127           USE P1;
 128
 129           TYPE NEW_T IS NEW SUB_T;
 130           OBJ_NEWT : NEW_T;
 131      BEGIN
 132           PAC_VAR := SUB_T'(1.0);
 133           IF PAC_VAR /= OBJ_FIX THEN
 134                FAILED ("INCORRECT RESULTS - 1");
 135           END IF;
 136           OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX);
 137           IF OBJ_FIX <= PAC_VAR THEN
 138                FAILED ("INCORRECT RESULTS - 2");
 139           END IF;
 140           PAC_VAR := OBJ_INT * OBJ_FIX;
 141           IF PAC_VAR NOT IN FIXED THEN
 142                FAILED ("INCORRECT RESULTS - 3");
 143           END IF;
 144           IF OBJ_FIX NOT IN SUB_T THEN
 145                FAILED ("INCORRECT RESULTS - 4");
 146           END IF;
 147           IF SUB_T'DELTA /= 0.125 THEN
 148                FAILED ("INCORRECT RESULTS - 5");
 149           END IF;
 150           OBJ_NEWT := 1.0;
 151           OBJ_NEWT := OBJ_NEWT - 1.0;
 152           IF OBJ_NEWT NOT IN NEW_T THEN
 153                FAILED ("INCORRECT RESULTS - 6");
 154           END IF;
 155           IF NEW_T'DELTA /= 0.125 THEN
 156                FAILED ("INCORRECT RESULTS - 7");
 157           END IF;
 158           OBJ_NEWT := NEW_T'SMALL + 1.0;
 159           OBJ_FIX := 1.0;
 160           OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX);
 161           IF OBJ_FIX /= 1.0 THEN
 162                FAILED ("INCORRECT RESULTS - 8");
 163           END IF;
 164           OBJ_FIX := 1.0;
 165           OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX);
 166           IF OBJ_FIX /= 1.0 THEN
 167                FAILED ("INCORRECT RESULTS - 9");
 168           END IF;
 169           IF FIXED'SMALL /= NEW_T'SMALL THEN
 170                FAILED ("INCORRECT RESULTS - 10");
 171           END IF;
 172      END;
 173
 174      RESULT;
 175 END CC3233A;