Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c9/c95085a.ada @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 -- C95085A.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 CONSTRAINT_ERROR IS RAISED FOR OUT OF RANGE SCALAR
26 -- ARGUMENTS. SUBTESTS ARE:
27 -- (A) STATIC IN ARGUMENT.
28 -- (B) DYNAMIC IN ARGUMENT.
29 -- (C) IN OUT, OUT OF RANGE ON CALL.
30 -- (D) OUT, OUT OF RANGE ON RETURN.
31 -- (E) IN OUT, OUT OF RANGE ON RETURN.
32
33 -- GLH 7/15/85
34 -- JRK 8/23/85
35 -- JWC 11/15/85 ADDED VARIABLE "CALLED" TO ENSURE THAT THE ENTRY
36 -- CALL WAS MADE FOR THOSE CASES THAT ARE APPLICABLE.
37
38 WITH REPORT; USE REPORT;
39 PROCEDURE C95085A IS
40
41 SUBTYPE DIGIT IS INTEGER RANGE 0..9;
42
43 D : DIGIT;
44 I : INTEGER;
45 M1 : CONSTANT INTEGER := IDENT_INT (-1);
46 COUNT : INTEGER := 0;
47 CALLED : BOOLEAN;
48
49 SUBTYPE SI IS INTEGER RANGE M1 .. 10;
50
51 TASK T1 IS
52 ENTRY E1 (PIN : IN DIGIT; WHO : STRING); -- (A), (B).
53 END T1;
54
55 TASK BODY T1 IS
56 BEGIN
57 LOOP
58 BEGIN
59 SELECT
60 ACCEPT E1 (PIN : IN DIGIT;
61 WHO : STRING) DO -- (A), (B).
62 FAILED ("EXCEPTION NOT RAISED BEFORE " &
63 "CALL - E1 " & WHO);
64 END E1;
65 OR
66 TERMINATE;
67 END SELECT;
68 EXCEPTION
69 WHEN OTHERS =>
70 FAILED ("EXCEPTION RAISED IN E1");
71 END;
72 END LOOP;
73 END T1;
74
75 TASK T2 IS
76 ENTRY E2 (PINOUT : IN OUT DIGIT; WHO : STRING); -- (C).
77 END T2;
78
79 TASK BODY T2 IS
80 BEGIN
81 LOOP
82 BEGIN
83 SELECT
84 ACCEPT E2 (PINOUT : IN OUT DIGIT;
85 WHO : STRING) DO -- (C).
86 FAILED ("EXCEPTION NOT RAISED BEFORE " &
87 "CALL - E2 " & WHO);
88 END E2;
89 OR
90 TERMINATE;
91 END SELECT;
92 EXCEPTION
93 WHEN OTHERS =>
94 FAILED ("EXCEPTION RAISED IN E2");
95 END;
96 END LOOP;
97 END T2;
98
99 TASK T3 IS
100 ENTRY E3 (POUT : OUT SI; WHO : STRING); -- (D).
101 END T3;
102
103 TASK BODY T3 IS
104 BEGIN
105 LOOP
106 BEGIN
107 SELECT
108 ACCEPT E3 (POUT : OUT SI;
109 WHO : STRING) DO -- (D).
110 CALLED := TRUE;
111 IF WHO = "10" THEN
112 POUT := IDENT_INT (10); -- 10 IS NOT
113 -- A DIGIT.
114 ELSE
115 POUT := -1;
116 END IF;
117 END E3;
118 OR
119 TERMINATE;
120 END SELECT;
121 EXCEPTION
122 WHEN OTHERS =>
123 FAILED ("EXCEPTION RAISED IN E3");
124 END;
125 END LOOP;
126 END T3;
127
128 TASK T4 IS
129 ENTRY E4 (PINOUT : IN OUT INTEGER; WHO : STRING); -- (E).
130 END T4;
131
132 TASK BODY T4 IS
133 BEGIN
134 LOOP
135 BEGIN
136 SELECT
137 ACCEPT E4 (PINOUT : IN OUT INTEGER;
138 WHO : STRING) DO -- (E).
139 CALLED := TRUE;
140 IF WHO = "10" THEN
141 PINOUT := 10; -- 10 IS NOT A DIGIT.
142 ELSE
143 PINOUT := IDENT_INT (-1);
144 END IF;
145 END E4;
146 OR
147 TERMINATE;
148 END SELECT;
149 EXCEPTION
150 WHEN OTHERS =>
151 FAILED ("EXCEPTION RAISED IN E4");
152 END;
153 END LOOP;
154 END T4;
155
156 BEGIN
157
158 TEST ("C95085A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
159 "FOR OUT OF RANGE SCALAR ARGUMENTS");
160
161 BEGIN -- (A)
162 T1.E1 (10, "10");
163 FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (10)");
164 EXCEPTION
165 WHEN CONSTRAINT_ERROR =>
166 COUNT := COUNT + 1;
167 WHEN OTHERS =>
168 FAILED ("WRONG EXCEPTION RAISED FOR E1 (10)");
169 END; -- (A)
170
171 BEGIN -- (B)
172 T1.E1 (IDENT_INT (-1), "-1");
173 FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (" &
174 "IDENT_INT (-1))");
175 EXCEPTION
176 WHEN CONSTRAINT_ERROR =>
177 COUNT := COUNT + 1;
178 WHEN OTHERS =>
179 FAILED ("WRONG EXCEPTION RAISED FOR E1 (" &
180 "IDENT_INT (-1))");
181 END; -- (B)
182
183 BEGIN -- (C)
184 I := IDENT_INT (10);
185 T2.E2 (I, "10");
186 FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (10)");
187 EXCEPTION
188 WHEN CONSTRAINT_ERROR =>
189 COUNT := COUNT + 1;
190 WHEN OTHERS =>
191 FAILED ("WRONG EXCEPTION RAISED FOR E2 (10)");
192 END; -- (C)
193
194 BEGIN -- (C1)
195 I := IDENT_INT (-1);
196 T2.E2 (I, "-1");
197 FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (-1)");
198 EXCEPTION
199 WHEN CONSTRAINT_ERROR =>
200 COUNT := COUNT + 1;
201 WHEN OTHERS =>
202 FAILED ("WRONG EXCEPTION RAISED FOR E2 (-1)");
203 END; -- (C1)
204
205 BEGIN -- (D)
206 CALLED := FALSE;
207 D := IDENT_INT (1);
208 T3.E3 (D, "10");
209 FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " &
210 "E3 (10)");
211 EXCEPTION
212 WHEN CONSTRAINT_ERROR =>
213 COUNT := COUNT + 1;
214 IF NOT CALLED THEN
215 FAILED ("EXCEPTION RAISED BEFORE CALL " &
216 "E3 (10)");
217 END IF;
218 WHEN OTHERS =>
219 FAILED ("WRONG EXCEPTION RAISED FOR E3 (10)");
220 END; -- (D)
221
222 BEGIN -- (D1)
223 CALLED := FALSE;
224 D := IDENT_INT (1);
225 T3.E3 (D, "-1");
226 FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " &
227 "E3 (-1)");
228 EXCEPTION
229 WHEN CONSTRAINT_ERROR =>
230 COUNT := COUNT + 1;
231 IF NOT CALLED THEN
232 FAILED ("EXCEPTION RAISED BEFORE CALL " &
233 "E3 (-1)");
234 END IF;
235 WHEN OTHERS =>
236 FAILED ("WRONG EXCEPTION RAISED FOR E3 (-1)");
237 END; -- (D1)
238
239 BEGIN -- (E)
240 CALLED := FALSE;
241 D := 9;
242 T4.E4 (D, "10");
243 FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " &
244 "E4 (10)");
245 EXCEPTION
246 WHEN CONSTRAINT_ERROR =>
247 COUNT := COUNT + 1;
248 IF NOT CALLED THEN
249 FAILED ("EXCEPTION RAISED BEFORE CALL " &
250 "E4 (10)");
251 END IF;
252 WHEN OTHERS =>
253 FAILED ("WRONG EXCEPTION RAISED FOR E4 (10)");
254 END; -- (E)
255
256 BEGIN -- (E1)
257 CALLED := FALSE;
258 D := 0;
259 T4.E4 (D, "-1");
260 FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " &
261 "E4 (-1)");
262 EXCEPTION
263 WHEN CONSTRAINT_ERROR =>
264 COUNT := COUNT + 1;
265 IF NOT CALLED THEN
266 FAILED ("EXCEPTION RAISED BEFORE CALL " &
267 "E4 (-1)");
268 END IF;
269 WHEN OTHERS =>
270 FAILED ("WRONG EXCEPTION RAISED FOR E4 (-1)");
271 END; -- (E1)
272
273 IF COUNT /= 8 THEN
274 FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED");
275 END IF;
276
277 RESULT;
278
279 END C95085A;