gcc/testsuite/ada/acats/tests/cb/cb4002a.ada

   1 -- CB4002A.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 EXCEPTIONS RAISED DURING ELABORATION OF THE
  26 -- DECLARATIVE PART OF A SUBPROGRAM ARE PROPAGATED TO THE
  27 -- CALLER, FOR CONSTRAINT_ERROR CAUSED BY INITIALIZATION,
  28 -- AND CONSTRAINT ELABORATION, AND FOR FUNCTION EVALUATIONS
  29 -- RAISING  CONSTRAINT_ERROR AND A PROGRAMMER-DEFINED EXCEPTION.
  30
  31 -- DAT 4/13/81
  32 -- SPS 3/28/83
  33
  34 WITH REPORT; USE REPORT;
  35
  36 PROCEDURE CB4002A IS
  37 BEGIN
  38      TEST("CB4002A", "EXCEPTIONS IN SUBPROGRAM DECLARATIVE_PARTS"
  39           & " ARE PROPAGATED TO CALLER");
  40
  41      DECLARE
  42           SUBTYPE I5 IS INTEGER RANGE -5 .. 5;
  43
  44           E : EXCEPTION;
  45
  46           FUNCTION RAISE_IT (I : I5) RETURN INTEGER IS
  47                J : INTEGER RANGE 0 .. 1 := I;
  48           BEGIN
  49                IF I = 0 THEN
  50                     RAISE CONSTRAINT_ERROR;
  51                ELSIF I = 1 THEN
  52                     RAISE E;
  53                END IF;
  54                FAILED ("EXCEPTION NOT RAISED 0");
  55                RETURN J;
  56           EXCEPTION
  57                WHEN OTHERS =>
  58                     IF I NOT IN 0 .. 1 THEN
  59                          FAILED ("WRONG HANDLER 0");
  60                          RETURN 0;
  61                     ELSE
  62                          RAISE;
  63                     END IF;
  64           END RAISE_IT;
  65
  66           PROCEDURE P1 (P : INTEGER) IS
  67                Q : INTEGER := RAISE_IT (P);
  68           BEGIN
  69                FAILED ("EXCEPTION NOT RAISED 1");
  70           EXCEPTION
  71                WHEN OTHERS =>
  72                     FAILED ("WRONG HANDLER 1");
  73           END P1;
  74
  75           PROCEDURE P2 (P : INTEGER) IS
  76                Q : I5 RANGE 0 .. P := 1;
  77           BEGIN
  78                IF P = 0 OR P > 5 THEN
  79                     FAILED ("EXCEPTION NOT RAISED 2");
  80                END IF;
  81           END P2;
  82
  83      BEGIN
  84
  85           BEGIN
  86                P1(-1);
  87                FAILED ("EXCEPTION NOT RAISED 2A");
  88           EXCEPTION
  89                WHEN CONSTRAINT_ERROR => NULL;
  90           END;
  91
  92           BEGIN
  93                P1(0);
  94                FAILED ("EXCEPTION NOT RAISED 3");
  95           EXCEPTION
  96                WHEN CONSTRAINT_ERROR => NULL;
  97           END;
  98
  99           BEGIN
 100                P1(1);
 101                FAILED ("EXCEPTION NOT RAISED 4");
 102           EXCEPTION
 103                WHEN E => NULL;
 104           END;
 105
 106           BEGIN
 107                P2(0);
 108                FAILED ("EXCEPTION NOT RAISED 5");
 109           EXCEPTION
 110                WHEN CONSTRAINT_ERROR => NULL;
 111           END;
 112
 113           BEGIN
 114                P2(6);
 115                FAILED ("EXCEPTION NOT RAISED 6");
 116           EXCEPTION
 117                WHEN CONSTRAINT_ERROR => NULL;
 118           END;
 119
 120      EXCEPTION
 121           WHEN OTHERS => FAILED ("WRONG EXCEPTION OR HANDLER");
 122      END;
 123
 124      RESULT;
 125 EXCEPTION
 126      WHEN OTHERS => FAILED ("WRONG HANDLER FOR SURE"); RESULT;
 127 END CB4002A;