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
34WITH REPORT; USE REPORT;
35
36PROCEDURE CB4002A IS
37BEGIN
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;
125EXCEPTION
126     WHEN OTHERS => FAILED ("WRONG HANDLER FOR SURE"); RESULT;
127END CB4002A;
128