Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c9/c94008c.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 -- C94008C.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 SELECT WITH TERMINATE ALTERNATIVE WORKS CORRECTLY WITH
26 -- NESTED TASKS.
27
28 -- THIS TEST CONTAINS RACE CONDITIONS AND USES A GENERIC INSTANCE THAT
29 -- CONTAINS TASKS.
30
31 -- JEAN-PIERRE ROSEN 24 FEBRUARY 1984
32 -- JRK 4/7/86
33 -- JBG 8/29/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT
34 -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
35
36 with Impdef;
37 WITH REPORT; USE REPORT;
38 WITH SYSTEM; USE SYSTEM;
39 PROCEDURE C94008C IS
40
41
42 -- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES
43 GENERIC
44 TYPE HOLDER_TYPE IS PRIVATE;
45 TYPE VALUE_TYPE IS PRIVATE;
46 INITIAL_VALUE : HOLDER_TYPE;
47 WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE;
48 VALUE : IN HOLDER_TYPE) IS <>;
49 WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE;
50 VALUE : IN VALUE_TYPE) IS <>;
51 PACKAGE SHARED IS
52 PROCEDURE SET (VALUE : IN HOLDER_TYPE);
53 PROCEDURE UPDATE (VALUE : IN VALUE_TYPE);
54 FUNCTION GET RETURN HOLDER_TYPE;
55 END SHARED;
56
57 PACKAGE BODY SHARED IS
58 TASK SHARE IS
59 ENTRY SET (VALUE : IN HOLDER_TYPE);
60 ENTRY UPDATE (VALUE : IN VALUE_TYPE);
61 ENTRY READ (VALUE : OUT HOLDER_TYPE);
62 END SHARE;
63
64 TASK BODY SHARE IS
65 VARIABLE : HOLDER_TYPE;
66 BEGIN
67 LOOP
68 SELECT
69 ACCEPT SET (VALUE : IN HOLDER_TYPE) DO
70 SHARED.SET (VARIABLE, VALUE);
71 END SET;
72 OR
73 ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO
74 SHARED.UPDATE (VARIABLE, VALUE);
75 END UPDATE;
76 OR
77 ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO
78 VALUE := VARIABLE;
79 END READ;
80 OR
81 TERMINATE;
82 END SELECT;
83 END LOOP;
84 END SHARE;
85
86 PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS
87 BEGIN
88 SHARE.SET (VALUE);
89 END SET;
90
91 PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS
92 BEGIN
93 SHARE.UPDATE (VALUE);
94 END UPDATE;
95
96 FUNCTION GET RETURN HOLDER_TYPE IS
97 VALUE : HOLDER_TYPE;
98 BEGIN
99 SHARE.READ (VALUE);
100 RETURN VALUE;
101 END GET;
102
103 BEGIN
104 SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE
105 END SHARED;
106
107 PACKAGE EVENTS IS
108
109 TYPE EVENT_TYPE IS
110 RECORD
111 TRACE : STRING (1..4) := "....";
112 LENGTH : NATURAL := 0;
113 END RECORD;
114
115 PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER);
116 PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE);
117 END EVENTS;
118
119 PACKAGE COUNTER IS
120 PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER);
121 PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER);
122 END COUNTER;
123
124 PACKAGE BODY COUNTER IS
125 PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS
126 BEGIN
127 VAR := VAR + VAL;
128 END UPDATE;
129
130 PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS
131 BEGIN
132 VAR := VAL;
133 END SET;
134 END COUNTER;
135
136 PACKAGE BODY EVENTS IS
137 PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS
138 BEGIN
139 VAR.LENGTH := VAR.LENGTH + 1;
140 VAR.TRACE(VAR.LENGTH) := VAL;
141 END UPDATE;
142
143 PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS
144 BEGIN
145 VAR := VAL;
146 END SET;
147
148 END EVENTS;
149
150 USE EVENTS, COUNTER;
151
152 PACKAGE TRACE IS NEW SHARED (EVENT_TYPE, CHARACTER, ("....", 0));
153 PACKAGE TERMINATE_COUNT IS NEW SHARED (INTEGER, INTEGER, 0);
154
155 FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS
156 BEGIN
157 TERMINATE_COUNT.UPDATE (1);
158 RETURN TRUE;
159 END ENTER_TERMINATE;
160
161 BEGIN -- C94008C
162
163 TEST ("C94008C", "CHECK CORRECT OPERATION OF SELECT WITH " &
164 "TERMINATE ALTERNATIVE");
165
166 DECLARE
167
168 PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE;
169
170 TASK T1 IS
171 ENTRY E1;
172 END T1;
173
174 TASK BODY T1 IS
175
176 TASK T2 IS
177 ENTRY E2;
178 END T2;
179
180 TASK BODY T2 IS
181
182 TASK T3 IS
183 ENTRY E3;
184 END T3;
185
186 TASK BODY T3 IS
187 BEGIN
188 SELECT
189 ACCEPT E3;
190 OR WHEN ENTER_TERMINATE => TERMINATE;
191 END SELECT;
192 EVENT ('D');
193 END T3;
194
195 BEGIN -- T2
196
197 SELECT
198 ACCEPT E2;
199 OR WHEN ENTER_TERMINATE => TERMINATE;
200 END SELECT;
201
202 DELAY 10.0 * Impdef.One_Second;
203
204 IF TERMINATE_COUNT.GET /= 1 THEN
205 DELAY 20.0 * Impdef.One_Long_Second;
206 END IF;
207
208 IF TERMINATE_COUNT.GET /= 1 THEN
209 FAILED ("30 SECOND DELAY NOT ENOUGH - 1 ");
210 END IF;
211
212 EVENT ('C');
213 T1.E1;
214 T3.E3;
215 END T2;
216
217 BEGIN -- T1;
218
219 SELECT
220 ACCEPT E1;
221 OR WHEN ENTER_TERMINATE => TERMINATE;
222 END SELECT;
223
224 EVENT ('B');
225 TERMINATE_COUNT.SET (0);
226 T2.E2;
227
228 SELECT
229 ACCEPT E1;
230 OR WHEN ENTER_TERMINATE => TERMINATE;
231 END SELECT;
232
233 SELECT
234 ACCEPT E1;
235 OR TERMINATE; -- ONLY THIS ONE EVER CHOSEN.
236 END SELECT;
237
238 FAILED ("TERMINATE NOT SELECTED IN T1");
239 END T1;
240
241 BEGIN
242
243 DELAY 10.0 * Impdef.One_Second; -- WAIT FOR T1, T2, AND T3 TO GET TO SELECT STMTS.
244
245 IF TERMINATE_COUNT.GET /= 3 THEN
246 DELAY 20.0 * Impdef.One_Long_Second;
247 END IF;
248
249 IF TERMINATE_COUNT.GET /= 3 THEN
250 FAILED ("30 SECOND DELAY NOT ENOUGH - 2");
251 END IF;
252
253 EVENT ('A');
254 T1.E1;
255
256 EXCEPTION
257 WHEN OTHERS => FAILED ("EXCEPTION IN MAIN BLOCK");
258 END;
259
260 IF TRACE.GET.TRACE /= "ABCD" THEN
261 FAILED ("INCORRECT ORDER OF EVENTS: " & TRACE.GET.TRACE);
262 END IF;
263
264 RESULT;
265 END C94008C;