Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cxb/cxb3007.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 -- CXB3007.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 the procedure To_C converts the Wide_Character elements | |
28 -- of a Wide_String parameter into wchar_t elements of the wchar_array | |
29 -- parameter Target, with wide_nul termination if parameter Append_Nul | |
30 -- is true. | |
31 -- | |
32 -- Check that the out parameter Count of procedure To_C is set to the | |
33 -- appropriate value for both the wide_nul/no wide_nul terminated cases. | |
34 -- | |
35 -- Check that Constraint_Error is propagated by procedure To_C if the | |
36 -- length of the wchar_array parameter Target is not sufficient to | |
37 -- hold the converted Wide_String value. | |
38 -- | |
39 -- Check that the Procedure To_Ada converts wchar_t elements of the | |
40 -- wchar_array parameter Item to the corresponding Wide_Character | |
41 -- elements of Wide_String out parameter Target. | |
42 -- | |
43 -- Check that Constraint_Error is propagated by Procedure To_Ada if the | |
44 -- length of Wide_String parameter Target is not long enough to hold the | |
45 -- converted wchar_array value. | |
46 -- | |
47 -- Check that Terminator_Error is propagated by Procedure To_Ada if the | |
48 -- parameter Trim_Nul is set to True, but the actual Item parameter | |
49 -- contains no wide_nul wchar_t. | |
50 -- | |
51 -- TEST DESCRIPTION: | |
52 -- This test uses a variety of Wide_String, and wchar_array objects to | |
53 -- test versions of the To_C and To_Ada procedures. | |
54 -- | |
55 -- This test assumes that the following characters are all included | |
56 -- in the implementation defined type Interfaces.C.wchar_t: | |
57 -- ' ', 'a'..'z', 'A'..'Z', and '-'. | |
58 -- | |
59 -- APPLICABILITY CRITERIA: | |
60 -- This test is applicable to all implementations that provide | |
61 -- package Interfaces.C. If an implementation provides | |
62 -- package Interfaces.C, this test must compile, execute, and | |
63 -- report "PASSED". | |
64 -- | |
65 -- CHANGE HISTORY: | |
66 -- 01 Sep 95 SAIC Initial prerelease version. | |
67 -- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. | |
68 -- 26 Oct 96 SAIC Incorporated reviewer comments. | |
69 -- 14 Sep 99 RLB Removed incorrect and unnecessary | |
70 -- Unchecked_Conversion. | |
71 -- | |
72 --! | |
73 | |
74 with Report; | |
75 with Interfaces.C; -- N/A => ERROR | |
76 with Ada.Characters.Latin_1; | |
77 with Ada.Characters.Handling; | |
78 with Ada.Exceptions; | |
79 with Ada.Strings.Wide_Fixed; | |
80 | |
81 procedure CXB3007 is | |
82 begin | |
83 | |
84 Report.Test ("CXB3007", "Check that the procedures To_C and To_Ada " & | |
85 "for wide strings produce correct results"); | |
86 Test_Block: | |
87 declare | |
88 | |
89 use Interfaces, Interfaces.C; | |
90 use Ada.Characters, Ada.Characters.Handling; | |
91 use Ada.Exceptions; | |
92 use Ada.Strings.Wide_Fixed; | |
93 | |
94 TC_Short_Wide_String : Wide_String(1..4) := | |
95 (others => Wide_Character'First); | |
96 TC_Wide_String : Wide_String(1..8) := | |
97 (others => Wide_Character'First); | |
98 TC_wchar_array : wchar_array(0..7) := (others => wchar_t'First); | |
99 TC_size_t_Count : size_t := size_t'First; | |
100 TC_Natural_Count : Natural := Natural'First; | |
101 | |
102 | |
103 -- We can use the wide character forms of To_Ada and To_C here to check | |
104 -- the results; they were tested in CXB3006. We give them different | |
105 -- names to avoid confusion below. | |
106 | |
107 function Wide_Character_to_wchar_t (Source : in Wide_Character) | |
108 return wchar_t renames To_C; | |
109 function wchar_t_to_Wide_Character (Source : in wchar_t) | |
110 return Wide_Character renames To_Ada; | |
111 | |
112 begin | |
113 | |
114 -- Check that the procedure To_C converts the Wide_Character elements | |
115 -- of a Wide_String parameter into wchar_t elements of wchar_array out | |
116 -- parameter Target. | |
117 -- | |
118 -- Case of wide_nul termination. | |
119 | |
120 TC_Wide_String(1..6) := "abcdef"; | |
121 | |
122 To_C (Item => TC_Wide_String(1..6), -- Source slice of length 6. | |
123 Target => TC_wchar_array, | |
124 Count => TC_size_t_Count, | |
125 Append_Nul => True); | |
126 | |
127 -- Check that the out parameter Count is set to the appropriate value | |
128 -- for the wide_nul terminated case. | |
129 | |
130 if TC_size_t_Count /= 7 then | |
131 Report.Failed("Incorrect setting of out parameter Count by " & | |
132 "Procedure To_C when Append_Nul => True"); | |
133 end if; | |
134 | |
135 for i in 1..TC_size_t_Count-1 loop | |
136 if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /= | |
137 TC_Wide_String(Integer(i)) | |
138 then | |
139 Report.Failed("Incorrect result from Procedure To_C when " & | |
140 "checking individual wchar_t values, case of " & | |
141 "Append_Nul => True; " & | |
142 "wchar_t position = " & Integer'Image(Integer(i))); | |
143 end if; | |
144 end loop; | |
145 | |
146 if not Is_Nul_Terminated(TC_wchar_array) then | |
147 Report.Failed("No wide_nul wchar_t appended to the wchar_array " & | |
148 "result from Procedure To_C when Append_Nul => True"); | |
149 end if; | |
150 | |
151 if TC_wchar_array(0..6) /= To_C("abcdef", True) then | |
152 Report.Failed("Incorrect result from Procedure To_C when " & | |
153 "directly comparing wchar_array results, case " & | |
154 "of Append_Nul => True"); | |
155 end if; | |
156 | |
157 | |
158 -- Check Procedure To_C with no wide_nul termination. | |
159 | |
160 TC_wchar_array := (others => Wide_Character_to_wchar_t('M')); | |
161 TC_Wide_String(1..4) := "WXYZ"; | |
162 | |
163 To_C (Item => TC_Wide_String(1..4), -- Source slice of length 4. | |
164 Target => TC_wchar_array, | |
165 Count => TC_size_t_Count, | |
166 Append_Nul => False); | |
167 | |
168 -- Check that the out parameter Count is set to the appropriate value | |
169 -- for the non-wide_nul terminated case. | |
170 | |
171 if TC_size_t_Count /= 4 then | |
172 Report.Failed("Incorrect setting of out parameter Count by " & | |
173 "Procedure To_C when Append_Nul => False"); | |
174 end if; | |
175 | |
176 for i in 1..TC_size_t_Count loop | |
177 if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /= | |
178 TC_Wide_String(Integer(i)) | |
179 then | |
180 Report.Failed("Incorrect result from Procedure To_C when " & | |
181 "checking individual wchar_t values, case of " & | |
182 "Append_Nul => False; " & | |
183 "wchar_t position = " & Integer'Image(Integer(i))); | |
184 end if; | |
185 end loop; | |
186 | |
187 if Is_Nul_Terminated(TC_wchar_array) then | |
188 Report.Failed | |
189 ("The wide_nul wchar_t was appended to the wchar_array " & | |
190 "result of Procedure To_C when Append_Nul => False"); | |
191 end if; | |
192 | |
193 if TC_wchar_array(0..3) /= To_C("WXYZ", False) then | |
194 Report.Failed("Incorrect result from Procedure To_C when " & | |
195 "directly comparing wchar_array results, case " & | |
196 "of Append_Nul => False"); | |
197 end if; | |
198 | |
199 | |
200 | |
201 -- Check that Constraint_Error is raised by procedure To_C if the | |
202 -- length of the target wchar_array parameter is not sufficient to | |
203 -- hold the converted Wide_String value (plus wide_nul if Append_Nul | |
204 -- is True). | |
205 | |
206 TC_wchar_array := (others => wchar_t'First); | |
207 begin | |
208 To_C("A string too long", | |
209 TC_wchar_array, | |
210 TC_size_t_Count, | |
211 Append_Nul => True); | |
212 | |
213 Report.Failed("Constraint_Error not raised when the Target " & | |
214 "parameter of Procedure To_C is not long enough " & | |
215 "to hold the converted Wide_String"); | |
216 Report.Comment | |
217 (To_Character(wchar_t_to_Wide_Character(TC_wchar_array(0))) & | |
218 " printed to defeat optimization"); | |
219 exception | |
220 when Constraint_Error => null; -- OK, expected exception. | |
221 when others => | |
222 Report.Failed("Incorrect exception raised by Procedure " & | |
223 "To_C when the Target parameter is not long " & | |
224 "enough to contain the wchar_array result"); | |
225 end; | |
226 | |
227 | |
228 | |
229 -- Check that the procedure To_Ada converts wchar_t elements of the | |
230 -- wchar_array parameter Item to the corresponding Wide_Character | |
231 -- elements of Wide_String out parameter Target, with result wide | |
232 -- string length based on the Trim_Nul parameter. | |
233 -- | |
234 -- Case of appended wide_nul wchar_t on the wchar_array In parameter. | |
235 | |
236 TC_wchar_array := | |
237 To_C ("ACVC-95", Append_Nul => True); -- 8 total chars. | |
238 | |
239 To_Ada (Item => TC_wchar_array, | |
240 Target => TC_Wide_String, | |
241 Count => TC_Natural_Count, | |
242 Trim_Nul => False); | |
243 | |
244 if TC_Natural_Count /= 8 then | |
245 Report.Failed("Incorrect value returned in out parameter Count " & | |
246 "by Procedure To_Ada, case of Trim_Nul => False"); | |
247 end if; | |
248 | |
249 for i in 1..TC_Natural_Count loop | |
250 if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= | |
251 TC_wchar_array(size_t(i-1)) | |
252 then | |
253 Report.Failed("Incorrect result from Procedure To_Ada when " & | |
254 "checking individual wchar_t values, case of " & | |
255 "Trim_Nul => False, when a wide_nul is present " & | |
256 "in the wchar_array input parameter; " & | |
257 "position = " & Integer'Image(Integer(i))); | |
258 end if; | |
259 end loop; | |
260 | |
261 if TC_Wide_String(TC_Natural_Count) /= To_Wide_Character(Latin_1.Nul) | |
262 then | |
263 Report.Failed("Last Wide_Character of Wide_String result of " & | |
264 "Procedure To_Ada is not Nul, even though a " & | |
265 "wide_nul was present in the wchar_array argument, " & | |
266 "and the Trim_Nul parameter was set to False"); | |
267 end if; | |
268 | |
269 | |
270 TC_Wide_String := (others => Wide_Character'First); | |
271 TC_wchar_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars. | |
272 | |
273 To_Ada (Item => TC_wchar_array, | |
274 Target => TC_Wide_String, | |
275 Count => TC_Natural_Count, | |
276 Trim_Nul => True); | |
277 | |
278 if TC_Natural_Count /= 3 then | |
279 Report.Failed("Incorrect value returned in out parameter Count " & | |
280 "by Procedure To_Ada, case of Trim_Nul => True"); | |
281 end if; | |
282 | |
283 for i in 1..TC_Natural_Count loop | |
284 if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= | |
285 TC_wchar_array(size_t(i-1)) | |
286 then | |
287 Report.Failed("Incorrect result from Procedure To_Ada when " & | |
288 "checking individual wchar_t values, case of " & | |
289 "Trim_Nul => True, when a wide_nul is present " & | |
290 "in the wchar_array input parameter; " & | |
291 "position = " & Integer'Image(Integer(i))); | |
292 end if; | |
293 end loop; | |
294 | |
295 if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul) | |
296 then | |
297 Report.Failed("Last Wide_Character of Wide_String result of " & | |
298 "Procedure To_Ada is Nul, even though the " & | |
299 "Trim_Nul parameter was set to True"); | |
300 end if; | |
301 | |
302 if TC_Wide_String(TC_Natural_Count+1) /= Wide_Character'First then | |
303 Report.Failed("Incorrect replacement from To_Ada"); | |
304 end if; | |
305 | |
306 | |
307 -- Case of no wide_nul wchar_t present in the wchar_array argument. | |
308 | |
309 TC_Wide_String := (others => Wide_Character'First); | |
310 TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False); | |
311 | |
312 To_Ada (Item => TC_wchar_array, | |
313 Target => TC_Wide_String, | |
314 Count => TC_Natural_Count, | |
315 Trim_Nul => False); | |
316 | |
317 if TC_Natural_Count /= 8 then | |
318 Report.Failed("Incorrect value returned in out parameter Count " & | |
319 "by Procedure To_Ada, case of Trim_Nul => False, " & | |
320 "with no wide_nul wchar_t present in the parameter " & | |
321 "Item"); | |
322 end if; | |
323 | |
324 for i in 1..TC_Natural_Count loop | |
325 if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= | |
326 TC_wchar_array(size_t(i-1)) | |
327 then | |
328 Report.Failed("Incorrect result from Procedure To_Ada when " & | |
329 "checking individual wchar_t values, case of " & | |
330 "Trim_Nul => False, when a wide_nul is not " & | |
331 "present in the wchar_array input parameter; " & | |
332 "position = " & Integer'Image(Integer(i))); | |
333 end if; | |
334 end loop; | |
335 | |
336 if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul) | |
337 then | |
338 Report.Failed("Last Wide_Character of Wide_String result of " & | |
339 "Procedure To_Ada is Nul, even though the wide_nul " & | |
340 "wchar_t was not present in the parameter Item, " & | |
341 "with the parameter Trim_Nul => False"); | |
342 end if; | |
343 | |
344 | |
345 | |
346 -- Check that the Procedure To_Ada raises Terminator_Error if the | |
347 -- parameter Trim_Nul is set to True, but the actual Item parameter | |
348 -- does not contain the wide_nul wchar_t. | |
349 | |
350 begin | |
351 TC_Wide_String := (others => Wide_Character'First); | |
352 TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False); | |
353 | |
354 To_Ada(TC_wchar_array, | |
355 TC_Wide_String, | |
356 Count => TC_Natural_Count, | |
357 Trim_Nul => True); | |
358 | |
359 Report.Failed("Terminator_Error not raised when Item " & | |
360 "parameter of To_Ada does not contain the " & | |
361 "wide_nul wchar_t, but parameter Trim_Nul => True"); | |
362 Report.Comment(To_String(TC_Wide_String) & | |
363 " printed to defeat optimization"); | |
364 exception | |
365 when Terminator_Error => null; -- OK, expected exception. | |
366 when others => | |
367 Report.Failed("Incorrect exception raised by Procedure " & | |
368 "To_Ada when the Item parameter does not " & | |
369 "contain the wide_nul wchar_t, but parameter " & | |
370 "Trim_Nul => True"); | |
371 end; | |
372 | |
373 | |
374 | |
375 -- Check that Constraint_Error is propagated by procedure To_Ada if the | |
376 -- length of Wide_String parameter Target is not long enough to hold the | |
377 -- converted wchar_array value (plus wide_nul if Trim_Nul is False). | |
378 | |
379 begin | |
380 TC_wchar_array(0..4) := To_C ("ABCD", Append_Nul => True); | |
381 | |
382 To_Ada(TC_wchar_array(0..4), | |
383 TC_Short_Wide_String, -- Length of 4. | |
384 Count => TC_Natural_Count, | |
385 Trim_Nul => False); | |
386 | |
387 Report.Failed("Constraint_Error not raised when Wide_String " & | |
388 "parameter Target of Procedure To_Ada is not " & | |
389 "long enough to hold the converted wchar_ts"); | |
390 Report.Comment(To_String(TC_Short_Wide_String) & | |
391 " printed to defeat optimization"); | |
392 exception | |
393 when Constraint_Error => null; -- OK, expected exception. | |
394 when others => | |
395 Report.Failed("Incorrect exception raised by Procedure " & | |
396 "To_Ada when Wide_String parameter Target is " & | |
397 "not long enough to hold the converted wchar_ts"); | |
398 end; | |
399 | |
400 exception | |
401 when The_Error : others => | |
402 Report.Failed ("The following exception was raised in the " & | |
403 "Test_Block: " & Exception_Name(The_Error)); | |
404 end Test_Block; | |
405 | |
406 Report.Result; | |
407 | |
408 end CXB3007; |