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

   1 -- C34004C.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 --     FOR DERIVED FIXED POINT TYPES:
  27
  28 --     CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
  29 --     THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
  30 --     CONSTRAINED.
  31
  32 --     CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
  33 --     IMPOSED ON THE DERIVED SUBTYPE.
  34
  35 -- HISTORY:
  36 --     JRK 09/08/86
  37 --     JLH 09/25/87  REFORMATTED HEADER.
  38 --     JRL 03/13/92  MODIFIED TO DEFEAT OPTIMIZATION WHEN ATTEMPTING TO
  39 --                   RAISE CONSTRAINT_ERROR.
  40 --     JRL 03/30/93  REMOVED NUMERIC_ERROR FROM TEST.
  41 --     DTN 11/30/95  REMOVED NON ADA95 ATTRIBUTES.
  42
  43 WITH SYSTEM; USE SYSTEM;
  44 WITH REPORT; USE REPORT;
  45
  46 PROCEDURE C34004C IS
  47
  48      TYPE PARENT IS DELTA 0.01 RANGE -100.0 .. 100.0;
  49
  50      TYPE T IS NEW PARENT DELTA 0.1 RANGE
  51                IDENT_INT (1) * (-30.0) ..
  52                IDENT_INT (1) * ( 30.0);
  53
  54      SUBTYPE SUBPARENT IS PARENT DELTA 0.1 RANGE -30.0 .. 30.0;
  55
  56      TYPE S IS NEW SUBPARENT;
  57
  58      X,XA : T;
  59      Y,YA : S;
  60
  61
  62      FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : T ) RETURN BOOLEAN IS
  63      BEGIN
  64         IF ( VAR1 + VAR2 ) IN T THEN
  65            RETURN FALSE ;
  66         ELSE
  67            RETURN TRUE ;
  68         END IF ;
  69      EXCEPTION
  70         WHEN CONSTRAINT_ERROR =>
  71            RETURN TRUE ;
  72      END OUT_OF_BOUNDS ;
  73
  74
  75      FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : S ) RETURN BOOLEAN IS
  76      BEGIN
  77         IF ( VAR1 + VAR2 ) IN S THEN
  78            RETURN FALSE ;
  79         ELSE
  80            RETURN TRUE ;
  81         END IF ;
  82      EXCEPTION
  83         WHEN CONSTRAINT_ERROR =>
  84            RETURN TRUE ;
  85      END OUT_OF_BOUNDS ;
  86
  87
  88 BEGIN
  89      TEST ("C34004C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
  90                       "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
  91                       "WHEN THE DERIVED TYPE DEFINITION IS " &
  92                       "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
  93                       "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
  94                       "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
  95                       "FIXED POINT TYPES");
  96
  97      -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
  98
  99      DECLARE
 100           TBD : CONSTANT := BOOLEAN'POS (T'BASE'DELTA <= 0.01);
 101           SBD : CONSTANT := BOOLEAN'POS (S'BASE'DELTA <= 0.01);
 102      BEGIN
 103           IF TBD = 0 OR SBD = 0 THEN
 104                FAILED ("INCORRECT 'BASE'DELTA");
 105           END IF;
 106      END;
 107
 108
 109      DECLARE
 110           N : INTEGER := IDENT_INT (8);
 111      BEGIN
 112           IF  98.0 + T'(1.0) + N * 0.0078125 /=  99.0625 OR
 113               98.0 + S'(1.0) + 8 * 0.0078125 /=  99.0625 OR
 114              -98.0 - T'(1.0) - N * 0.0078125 /= -99.0625 OR
 115              -98.0 - S'(1.0) - 8 * 0.0078125 /= -99.0625 THEN
 116                FAILED ("INCORRECT + OR -");
 117           END IF;
 118      END;
 119
 120
 121      IF T'FIRST /= -30.0 OR T'LAST /= 30.0 OR
 122         S'FIRST /= -30.0 OR S'LAST /= 30.0 THEN
 123           FAILED ("INCORRECT 'FIRST OR 'LAST");
 124      END IF;
 125
 126      BEGIN
 127           X := -30.0;
 128           Y := -30.0;
 129           IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
 130                FAILED ("INCORRECT CONVERSION TO PARENT - 1");
 131           END IF;
 132           X := 30.0;
 133           Y := 30.0;
 134           IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
 135                FAILED ("INCORRECT CONVERSION TO PARENT - 2");
 136           END IF;
 137      EXCEPTION
 138           WHEN OTHERS =>
 139                FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
 140      END;
 141
 142
 143      BEGIN
 144           X  := -30.0 ;
 145           XA := -0.0625 ;
 146           IF NOT OUT_OF_BOUNDS ( X , XA ) THEN
 147              FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := -30.0625" ) ;
 148           END IF ;
 149      EXCEPTION
 150           WHEN OTHERS =>
 151                FAILED ("WRONG EXCEPTION RAISED -- X := -30.0625");
 152      END;
 153
 154
 155      BEGIN
 156           X  := 30.0 ;
 157           XA := 0.0625 ;
 158           IF NOT OUT_OF_BOUNDS ( X , XA ) THEN
 159              FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := 30.0625" ) ;
 160           END IF ;
 161      EXCEPTION
 162           WHEN OTHERS =>
 163                FAILED ("WRONG EXCEPTION RAISED -- X := 30.0625");
 164      END;
 165
 166
 167      BEGIN
 168           Y  := -30.0 ;
 169           YA := -0.0625 ;
 170           IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN
 171              FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := -30.0625" ) ;
 172           END IF ;
 173      EXCEPTION
 174           WHEN OTHERS =>
 175                FAILED ("WRONG EXCEPTION RAISED -- Y := -30.0625");
 176      END;
 177
 178
 179      BEGIN
 180           Y  := 30.0 ;
 181           YA := 0.0625 ;
 182           IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN
 183              FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := 30.0625" ) ;
 184           END IF ;
 185      EXCEPTION
 186           WHEN OTHERS =>
 187                FAILED ("WRONG EXCEPTION RAISED -- Y := 30.0625");
 188      END;
 189
 190      RESULT;
 191 END C34004C;