Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cb/cb4002a.ada @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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; |