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

   1 -- C34018A.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 CALLS OF DERIVED SUBPROGRAMS CHECK CONSTRAINTS OF THE
  26 -- PARENT SUBPROGRAM, NOT THE CONSTRAINTS OF THE DERIVED SUBTYPE.
  27
  28 -- JBG 11/15/85
  29 -- JRK 2/12/86   CORRECTED ERROR: RESOLVED AMBIGUOUS CALL G(41) TO
  30 --               TYPE NEW_INT.
  31 -- EDS 7/16/98   AVOID OPTIMIZATION
  32
  33 WITH REPORT; USE REPORT;
  34 PROCEDURE C34018A IS
  35
  36      PACKAGE P IS
  37           TYPE INT IS RANGE 1..100;
  38           SUBTYPE INT_50 IS INT RANGE 1..50;
  39           SUBTYPE INT_51 IS INT RANGE 51..100;
  40
  41           FUNCTION "+" (L, R : INT) RETURN INT;
  42           FUNCTION G (X : INT_50) RETURN INT_51;
  43
  44           TYPE STR IS ARRAY (1..10) OF CHARACTER;
  45           FUNCTION F (X : STR) RETURN STR;
  46      END P;
  47
  48      USE P;
  49
  50      TYPE NEW_STR IS NEW P.STR;
  51      TYPE NEW_INT IS NEW P.INT RANGE 51..90;
  52
  53      PACKAGE BODY P IS
  54
  55           FUNCTION "+" (L, R : INT) RETURN INT IS
  56           BEGIN
  57                RETURN INT(INTEGER(L) + INTEGER(R));
  58           END "+";
  59
  60           FUNCTION G (X : INT_50) RETURN INT_51 IS
  61           BEGIN
  62                RETURN X + 10;
  63           END G;
  64
  65           FUNCTION F (X : STR) RETURN STR IS
  66           BEGIN
  67                RETURN X;
  68           END F;
  69
  70      END P;
  71
  72 BEGIN
  73
  74      TEST ("C34018A", "CHECK CONSTRAINTS PROCESSED CORRECTLY FOR " &
  75                       "CALLS OF DERIVED SUBPROGRAMS");
  76
  77      DECLARE
  78
  79           Y : NEW_STR := F("1234567890");    -- UNAMBIGUOUS.
  80
  81      BEGIN
  82           IF Y /= "1234567890" THEN
  83                FAILED ("DERIVED F");
  84           END IF;
  85      END;
  86
  87      DECLARE
  88
  89           A : INT := 51;
  90           B : NEW_INT := NEW_INT(IDENT_INT(90));
  91
  92      BEGIN
  93
  94           BEGIN
  95                A := A + 0;
  96                FAILED ("NO EXCEPTION - A + 0 = " & INT'IMAGE(A) ); --Use A
  97           EXCEPTION
  98                WHEN CONSTRAINT_ERROR =>
  99                     NULL;
 100                WHEN OTHERS =>
 101                     FAILED ("UNEXPECTED EXCEPTION - 1");
 102           END;
 103
 104           BEGIN
 105                IF B + 2 /= 92 THEN      -- 92 IN INT.
 106                     FAILED ("WRONG RESULT - B + 2");
 107                END IF;
 108           EXCEPTION
 109                WHEN CONSTRAINT_ERROR =>
 110                     FAILED ("WRONG CONSTRAINT FOR DERIVED ""+""");
 111                WHEN OTHERS =>
 112                     FAILED ("UNEXPECTED EXCEPTION - 2");
 113           END;
 114
 115           BEGIN
 116                IF B + 14 > 90 THEN      -- 104 NOT IN INT.
 117                     FAILED ("NO EXCEPTION RAISED FOR DERIVED ""+""");
 118                END IF;
 119           EXCEPTION
 120                WHEN CONSTRAINT_ERROR =>
 121                     NULL;
 122                WHEN OTHERS =>
 123                     FAILED ("UNEXPECTED EXCEPTION - 3");
 124           END;
 125
 126
 127           BEGIN
 128                IF G(B) > 90 THEN        -- 90 NOT IN INT_50.
 129                     FAILED ("NO EXCEPTION RAISED FOR DERIVED G");
 130                END IF;
 131           EXCEPTION
 132                WHEN CONSTRAINT_ERROR =>
 133                     NULL;
 134                WHEN OTHERS =>
 135                     FAILED ("UNEXPECTED EXCEPTION - 4");
 136           END;
 137
 138           BEGIN
 139                IF C34018A.G(41) /= 51 THEN  -- 41 CONVERTED TO
 140                                             --    NEW_INT'BASE.
 141                                             -- 41 IN INT_50.
 142                                             -- 51 IN INT_51.
 143                     FAILED ("WRONG RESULT - G(41)");
 144                END IF;
 145           EXCEPTION
 146                WHEN CONSTRAINT_ERROR =>
 147                     FAILED ("C_E RAISED FOR LITERAL ARGUMENT");
 148                WHEN OTHERS =>
 149                     FAILED ("UNEXPECTED EXCEPTION - 5");
 150           END;
 151      END;
 152
 153      RESULT;
 154 END C34018A;