gcc/testsuite/ada/acats/tests/c4/c47005a.ada

   1 -- C47005A.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 --     WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A FLOATING
  27 --     POINT TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE
  28 --     OF THE OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK.
  29
  30 -- HISTORY:
  31 --     RJW 07/23/86  CREATED ORIGINAL TEST.
  32 --     BCB 08/19/87  CHANGED HEADER TO STANDARD HEADER FORMAT.  ADDED
  33 --                   TEST FOR UPPER SIDE OF RANGE.
  34
  35 WITH REPORT; USE REPORT;
  36 PROCEDURE C47005A IS
  37
  38 BEGIN
  39
  40      TEST( "C47005A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " &
  41                       "DENOTES A FLOATING POINT TYPE, CHECK THAT " &
  42                       "CONSTRAINT_ERROR IS RAISED WHEN THE VALUE " &
  43                       "OF THE OPERAND DOES NOT LIE WITHIN THE " &
  44                       "RANGE OF THE TYPE MARK" );
  45
  46      DECLARE
  47
  48           SUBTYPE SFLOAT IS FLOAT RANGE -1.0 .. 1.0;
  49
  50           FUNCTION IDENT (F : FLOAT) RETURN FLOAT IS
  51           BEGIN
  52                IF EQUAL (3, 3) THEN
  53                     RETURN F;
  54                ELSE
  55                     RETURN 0.0;
  56                END IF;
  57           END IDENT;
  58
  59      BEGIN
  60           IF SFLOAT'(IDENT (-2.0)) = -1.0 THEN
  61                FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
  62                         "SUBTYPE SFLOAT - 1");
  63           ELSE
  64                FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
  65                         "SUBTYPE SFLOAT - 2");
  66           END IF;
  67      EXCEPTION
  68           WHEN CONSTRAINT_ERROR =>
  69                NULL;
  70           WHEN OTHERS =>
  71                FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
  72                         "OF SUBTYPE SFLOAT" );
  73      END;
  74
  75      DECLARE
  76
  77           TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0;
  78           SUBTYPE SFLT IS FLT RANGE -1.0 .. 1.0;
  79
  80           FUNCTION IDENT (F : FLT) RETURN FLT IS
  81           BEGIN
  82                IF EQUAL (3, 3) THEN
  83                     RETURN F;
  84                ELSE
  85                     RETURN 0.0;
  86                END IF;
  87           END IDENT;
  88
  89      BEGIN
  90           IF SFLT'(IDENT (-2.0)) = -1.0 THEN
  91                FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
  92                         "SUBTYPE SFLT - 1");
  93           ELSE
  94                FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
  95                         "SUBTYPE SFLT - 2");
  96           END IF;
  97      EXCEPTION
  98           WHEN CONSTRAINT_ERROR =>
  99                NULL;
 100           WHEN OTHERS =>
 101                FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
 102                         "OF SUBTYPE SFLT" );
 103      END;
 104
 105      DECLARE
 106
 107           TYPE NFLT IS NEW FLOAT;
 108           SUBTYPE SNFLT IS NFLT RANGE -1.0 .. 1.0;
 109
 110           FUNCTION IDENT (F : NFLT) RETURN NFLT IS
 111           BEGIN
 112                IF EQUAL (3, 3) THEN
 113                     RETURN F;
 114                ELSE
 115                     RETURN 0.0;
 116                END IF;
 117           END IDENT;
 118
 119      BEGIN
 120           IF SNFLT'(IDENT (2.0)) = 1.0 THEN
 121                FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
 122                         "SUBTYPE SNFLT 1");
 123           ELSE
 124                FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
 125                         "SUBTYPE SNFLT 2");
 126           END IF;
 127      EXCEPTION
 128           WHEN CONSTRAINT_ERROR =>
 129                NULL;
 130           WHEN OTHERS =>
 131                FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
 132                         "OF SUBTYPE SNFLT" );
 133      END;
 134
 135      RESULT;
 136 END C47005A;