Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/c9/c980001.a @ 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 -- C980001.A | |
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 -- | |
26 -- OBJECTIVE: | |
27 -- Check that when a construct is aborted the execution of an Initialize | |
28 -- procedure as the last step of the default initialization of a | |
29 -- controlled object is abort-deferred. | |
30 -- | |
31 -- Check that when a construct is aborted the execution of a Finalize | |
32 -- procedure as part of the finalization of a controlled object is | |
33 -- abort-deferred. | |
34 -- | |
35 -- Check that an assignment operation to an object with a controlled | |
36 -- part is an abort-deferred operation. | |
37 -- | |
38 -- TEST DESCRIPTION: | |
39 -- The controlled operations which are being tested call a subprogram | |
40 -- which guarantees that the enclosing operation becomes aborted. | |
41 -- | |
42 -- Each object is created with a unique value to prevent optimizations | |
43 -- due to the values being the same. | |
44 -- | |
45 -- Two protected objects are utilized to warrant that the operations | |
46 -- are delayed in their execution until such time that the abort is | |
47 -- processed. The object Hold_Up is used to hold the targeted | |
48 -- operation in execution, the object Progress is used to communicate | |
49 -- to the driver software that progress is indeed being made. | |
50 -- | |
51 -- | |
52 -- CHANGE HISTORY: | |
53 -- 01 MAY 95 SAIC Initial version | |
54 -- 01 MAY 96 SAIC Revised for 2.1 | |
55 -- 11 DEC 96 SAIC Final revision for 2.1 | |
56 -- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock | |
57 --! | |
58 | |
59 ---------------------------------------------------------------- C980001_0 | |
60 | |
61 with Impdef; | |
62 with Ada.Finalization; | |
63 package C980001_0 is | |
64 | |
65 A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0; | |
66 Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration | |
67 := Impdef.Switch_To_New_Task * 4.0; | |
68 | |
69 function TC_Unique return Integer; | |
70 | |
71 type Sticks_In_Initialize is new Ada.Finalization.Controlled with record | |
72 Item: Integer := TC_Unique; | |
73 end record; | |
74 procedure Initialize( AV: in out Sticks_In_Initialize ); | |
75 | |
76 type Sticks_In_Adjust is new Ada.Finalization.Controlled with record | |
77 Item: Integer := TC_Unique; | |
78 end record; | |
79 procedure Adjust ( AV: in out Sticks_In_Adjust ); | |
80 | |
81 type Sticks_In_Finalize is new Ada.Finalization.Controlled with record | |
82 Item: Integer := TC_Unique; | |
83 end record; | |
84 procedure Finalize ( AV: in out Sticks_In_Finalize ); | |
85 | |
86 Initialize_Called : Boolean := False; | |
87 Adjust_Called : Boolean := False; | |
88 Finalize_Called : Boolean := False; | |
89 | |
90 protected type Sticker is | |
91 entry Lock; | |
92 procedure Unlock; | |
93 function Is_Locked return Boolean; | |
94 private | |
95 Locked : Boolean := False; | |
96 end Sticker; | |
97 | |
98 Hold_Up : Sticker; | |
99 Progress : Sticker; | |
100 | |
101 procedure Fail_And_Clear( Message : String ); | |
102 | |
103 | |
104 end C980001_0; | |
105 | |
106 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- | |
107 | |
108 with Report; | |
109 with TCTouch; | |
110 package body C980001_0 is | |
111 | |
112 TC_Master_Value : Integer := 0; | |
113 | |
114 | |
115 function TC_Unique return Integer is -- make all values unique. | |
116 begin | |
117 TC_Master_Value := TC_Master_Value +1; | |
118 return TC_Master_Value; | |
119 end TC_Unique; | |
120 | |
121 protected body Sticker is | |
122 | |
123 entry Lock when not Locked is | |
124 begin | |
125 Locked := True; | |
126 end Lock; | |
127 | |
128 procedure Unlock is | |
129 begin | |
130 Locked := False; | |
131 end Unlock; | |
132 | |
133 function Is_Locked return Boolean is | |
134 begin | |
135 return Locked; | |
136 end Is_Locked; | |
137 | |
138 end Sticker; | |
139 | |
140 procedure Initialize( AV: in out Sticks_In_Initialize ) is | |
141 begin | |
142 TCTouch.Touch('I'); -------------------------------------------------- I | |
143 Hold_Up.Unlock; -- cause the select to abort | |
144 Initialize_Called := True; | |
145 AV.Item := TC_Unique; | |
146 TCTouch.Touch('i'); -------------------------------------------------- i | |
147 Progress.Unlock; -- allows Wait_Your_Turn to continue | |
148 end Initialize; | |
149 | |
150 procedure Adjust ( AV: in out Sticks_In_Adjust ) is | |
151 begin | |
152 TCTouch.Touch('A'); -------------------------------------------------- A | |
153 Hold_Up.Unlock; -- cause the select to abort | |
154 Adjust_Called := True; | |
155 AV.Item := TC_Unique; | |
156 TCTouch.Touch('a'); -------------------------------------------------- a | |
157 Progress.Unlock; | |
158 end Adjust; | |
159 | |
160 procedure Finalize ( AV: in out Sticks_In_Finalize ) is | |
161 begin | |
162 TCTouch.Touch('F'); -------------------------------------------------- F | |
163 Hold_Up.Unlock; -- cause the select to abort | |
164 Finalize_Called := True; | |
165 AV.Item := TC_Unique; | |
166 TCTouch.Touch('f'); -------------------------------------------------- f | |
167 Progress.Unlock; | |
168 end Finalize; | |
169 | |
170 procedure Fail_And_Clear( Message : String ) is | |
171 begin | |
172 Report.Failed(Message); | |
173 Hold_Up.Unlock; | |
174 Progress.Unlock; | |
175 end Fail_And_Clear; | |
176 | |
177 end C980001_0; | |
178 | |
179 --------------------------------------------------------------------------- | |
180 | |
181 with Report; | |
182 with TCTouch; | |
183 with Impdef; | |
184 with C980001_0; | |
185 procedure C980001 is | |
186 | |
187 procedure Check_Initialize_Conditions is | |
188 begin | |
189 if not C980001_0.Initialize_Called then | |
190 C980001_0.Fail_And_Clear("Initialize did not correctly complete"); | |
191 end if; | |
192 TCTouch.Validate("Ii", "Initialization Sequence"); | |
193 end Check_Initialize_Conditions; | |
194 | |
195 procedure Check_Adjust_Conditions is | |
196 begin | |
197 if not C980001_0.Adjust_Called then | |
198 C980001_0.Fail_And_Clear("Adjust did not correctly complete"); | |
199 end if; | |
200 TCTouch.Validate("Aa", "Adjust Sequence"); | |
201 end Check_Adjust_Conditions; | |
202 | |
203 procedure Check_Finalize_Conditions is | |
204 begin | |
205 if not C980001_0.Finalize_Called then | |
206 C980001_0.Fail_And_Clear("Finalize did not correctly complete"); | |
207 end if; | |
208 TCTouch.Validate("FfFfFf", "Finalization Sequence", | |
209 Order_Meaningful => False); | |
210 end Check_Finalize_Conditions; | |
211 | |
212 procedure Wait_Your_Turn is | |
213 Overrun : Natural := 0; | |
214 begin | |
215 while C980001_0.Progress.Is_Locked loop -- and waits | |
216 delay C980001_0.A_Little_While; | |
217 Overrun := Overrun +1; | |
218 if Overrun > 10 then | |
219 C980001_0.Fail_And_Clear("Overrun expired lock"); | |
220 end if; | |
221 end loop; | |
222 end Wait_Your_Turn; | |
223 | |
224 begin -- Main test procedure. | |
225 | |
226 Report.Test ("C980001", "Check the interaction between asynchronous " & | |
227 "transfer of control and controlled types" ); | |
228 | |
229 C980001_0.Progress.Lock; | |
230 C980001_0.Hold_Up.Lock; | |
231 | |
232 select | |
233 C980001_0.Hold_Up.Lock; -- Init will unlock | |
234 | |
235 Wait_Your_Turn; -- abortable part is stuck in Initialize | |
236 Check_Initialize_Conditions; | |
237 | |
238 then abort | |
239 declare | |
240 Object : C980001_0.Sticks_In_Initialize; | |
241 begin | |
242 delay Impdef.Minimum_Task_Switch; | |
243 if Report.Ident_Int( Object.Item ) /= Object.Item then | |
244 Report.Failed("Optimization foil caused failure"); | |
245 end if; | |
246 C980001_0.Fail_And_Clear( | |
247 "Initialize test executed beyond expected region"); | |
248 end; | |
249 end select; | |
250 | |
251 C980001_0.Progress.Lock; | |
252 | |
253 select | |
254 C980001_0.Hold_Up.Lock; -- Adjust will unlock | |
255 | |
256 Wait_Your_Turn; -- abortable part is stuck in Adjust | |
257 Check_Adjust_Conditions; | |
258 | |
259 then abort | |
260 declare | |
261 Object1 : C980001_0.Sticks_In_Adjust; | |
262 Object2 : C980001_0.Sticks_In_Adjust; | |
263 begin | |
264 Object1 := Object2; | |
265 delay Impdef.Minimum_Task_Switch; | |
266 if Report.Ident_Int( Object2.Item ) | |
267 /= Report.Ident_Int( Object1.Item ) then | |
268 Report.Failed("Optimization foil 1 caused failure"); | |
269 end if; | |
270 C980001_0.Fail_And_Clear("Adjust test executed beyond expected region"); | |
271 end; | |
272 end select; | |
273 | |
274 C980001_0.Progress.Lock; | |
275 | |
276 select | |
277 C980001_0.Hold_Up.Lock; -- Finalize will unlock | |
278 | |
279 Wait_Your_Turn; -- abortable part is stuck in Finalize | |
280 Check_Finalize_Conditions; | |
281 | |
282 then abort | |
283 declare | |
284 Object1 : C980001_0.Sticks_In_Finalize; | |
285 Object2 : C980001_0.Sticks_In_Finalize; | |
286 begin | |
287 Object1 := Object2; -- cause a finalize call | |
288 delay Impdef.Minimum_Task_Switch; | |
289 if Report.Ident_Int( Object2.Item ) | |
290 /= Report.Ident_Int( Object1.Item ) then | |
291 Report.Failed("Optimization foil 2 caused failure"); | |
292 end if; | |
293 C980001_0.Fail_And_Clear( | |
294 "Finalize test executed beyond expected region"); | |
295 end; | |
296 end select; | |
297 | |
298 Report.Result; | |
299 | |
300 exception | |
301 when others => C980001_0.Fail_And_Clear("Exception in main"); | |
302 Report.Result; | |
303 end C980001; |