Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cxb/cxb3014.a @ 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 -- CXB3014.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 Function Value with Pointer and Element
28 -- parameters will return an Element_Array result of correct size
29 -- and content (up to and including the first "terminator" Element).
30 --
31 -- Check that the Function Value with Pointer and Length parameters
32 -- will return an Element_Array result of appropriate size and content
33 -- (the first Length elements pointed to by the parameter Ref).
34 --
35 -- Check that both versions of Function Value will propagate
36 -- Interfaces.C.Strings.Dereference_Error when the value of
37 -- the Ref pointer parameter is null.
38 --
39 -- TEST DESCRIPTION:
40 -- This test tests that both versions of Function Value from the
41 -- generic package Interfaces.C.Pointers are available and produce
42 -- correct results. The generic package is instantiated with size_t,
43 -- char, char_array, and nul as actual parameters, and subtests are
44 -- performed on each of the Value functions resulting from this
45 -- instantiation.
46 -- For both function versions, a test is performed where a portion of
47 -- a char_array is to be returned as the function result. Likewise,
48 -- a test is performed where each version of the function returns the
49 -- entire char_array referenced by the in parameter Ref.
50 -- Finally, both versions of Function Value are called with a null
51 -- pointer reference, to ensure that Dereference_Error is raised in
52 -- this case.
53 --
54 -- This test assumes that the following characters are all included
55 -- in the implementation defined type Interfaces.C.char:
56 -- ' ', 'a'..'z', and 'A'..'Z'.
57 --
58 -- APPLICABILITY CRITERIA:
59 -- This test is applicable to all implementations that provide
60 -- packages Interfaces.C.Strings and Interfaces.C.Pointers. If an
61 -- implementation provides packages Interfaces.C.Strings and
62 -- Interfaces.C.Pointers, this test must compile, execute, and
63 -- report "PASSED".
64 --
65 --
66 -- CHANGE HISTORY:
67 -- 19 Oct 95 SAIC Initial prerelease version.
68 -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
69 -- 23 Oct 96 SAIC Incorporated reviewer comments.
70 --
71 --!
72
73 with Report;
74 with Interfaces.C.Strings; -- N/A => ERROR
75 with Interfaces.C.Pointers; -- N/A => ERROR
76
77 procedure CXB3014 is
78
79 begin
80
81 Report.Test ("CXB3014", "Check that versions of the Value function " &
82 "from package Interfaces.C.Pointers produce " &
83 "correct results");
84
85 Test_Block:
86 declare
87
88 use type Interfaces.C.char, Interfaces.C.size_t;
89
90 Char_a : constant Interfaces.C.char := 'a';
91 Char_j : constant Interfaces.C.char := 'j';
92 Char_z : constant Interfaces.C.char := 'z';
93
94 subtype Lower_Case_chars is Interfaces.C.char range Char_a..Char_z;
95 subtype Char_Range is Interfaces.C.size_t range 0..26;
96
97 Local_nul : aliased Interfaces.C.char := Interfaces.C.nul;
98 TC_Array_Size : Interfaces.C.size_t := 20;
99
100 TC_String_1 : constant String := "abcdefghij";
101 TC_String_2 : constant String := "abcdefghijklmnopqrstuvwxyz";
102 TC_String_3 : constant String := "abcdefghijklmnopqrst";
103 TC_String_4 : constant String := "abcdefghijklmnopqrstuvwxyz";
104 TC_Blank_String : constant String := " ";
105
106 TC_Char_Array : Interfaces.C.char_array(Char_Range) :=
107 Interfaces.C.To_C(TC_String_2, True);
108
109 TC_Char_Array_1 : Interfaces.C.char_array(0..9);
110 TC_Char_Array_2 : Interfaces.C.char_array(Char_Range);
111 TC_Char_Array_3 : Interfaces.C.char_array(0..TC_Array_Size-1);
112 TC_Char_Array_4 : Interfaces.C.char_array(Char_Range);
113
114 package Char_Pointers is new
115 Interfaces.C.Pointers (Index => Interfaces.C.size_t,
116 Element => Interfaces.C.char,
117 Element_Array => Interfaces.C.char_array,
118 Default_Terminator => Interfaces.C.nul);
119
120 Char_Ptr : Char_Pointers.Pointer;
121
122 use type Char_Pointers.Pointer;
123
124 begin
125
126 -- Check that the Function Value with Pointer and Terminator Element
127 -- parameters will return an Element_Array result of appropriate size
128 -- and content (up to and including the first "terminator" Element.)
129
130 Char_Ptr := TC_Char_Array(0)'Access;
131
132 -- Provide a new Terminator char in the call of Function Value.
133 -- This call should return only a portion (the first 10 chars) of
134 -- the referenced char_array, up to and including the char 'j'.
135
136 TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr,
137 Terminator => Char_j);
138
139 if Interfaces.C.To_Ada(TC_Char_Array_1, False) /= TC_String_1 or
140 Interfaces.C.Is_Nul_Terminated(TC_Char_Array_1)
141 then
142 Report.Failed("Incorrect result from Function Value with Ref " &
143 "and Terminator parameters, when supplied with " &
144 "a non-default Terminator char");
145 end if;
146
147 -- Use the default Terminator char in the call of Function Value.
148 -- This call should return the entire char_array, including the
149 -- terminating nul char.
150
151 TC_Char_Array_2 := Char_Pointers.Value(Char_Ptr);
152
153 if Interfaces.C.To_Ada(TC_Char_Array_2, True) /= TC_String_2 or
154 not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_2)
155 then
156 Report.Failed("Incorrect result from Function Value with Ref " &
157 "and Terminator parameters, when using the " &
158 "default Terminator char");
159 end if;
160
161
162
163 -- Check that the Function Value with Pointer and Length parameters
164 -- will return an Element_Array result of appropriate size and content
165 -- (the first Length elements pointed to by the parameter Ref).
166
167 -- This call should return only a portion (the first 20 chars) of
168 -- the referenced char_array.
169
170 TC_Char_Array_3 :=
171 Char_Pointers.Value(Ref => Char_Ptr,
172 Length => Interfaces.C.ptrdiff_t(TC_Array_Size));
173
174 -- Verify the individual chars of the result.
175 for i in 0..TC_Array_Size-1 loop
176 if Interfaces.C.To_Ada(TC_Char_Array_3(i)) /=
177 TC_String_3(Integer(i)+1)
178 then
179 Report.Failed("Incorrect result from Function Value with " &
180 "Ref and Length parameters, when specifying " &
181 "a length less than the full array size");
182 exit;
183 end if;
184 end loop;
185
186 -- This call should return the entire char_array, including the
187 -- terminating nul char.
188
189 TC_Char_Array_4 := Char_Pointers.Value(Char_Ptr, 27);
190
191 if Interfaces.C.To_Ada(TC_Char_Array_4, True) /= TC_String_4 or
192 not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_4)
193 then
194 Report.Failed("Incorrect result from Function Value with Ref " &
195 "and Length parameters, when specifying the " &
196 "entire array size");
197 end if;
198
199
200
201 -- Check that both of the above versions of Function Value will
202 -- propagate Interfaces.C.Strings.Dereference_Error when the value of
203 -- the Ref Pointer parameter is null.
204
205 Char_Ptr := null;
206
207 begin
208 TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr,
209 Terminator => Char_j);
210 Report.Failed("Dereference_Error not raised by Function " &
211 "Value with Terminator parameter, when " &
212 "provided a null reference");
213 -- Call Report.Comment to ensure that the assignment to
214 -- TC_Char_Array_1 is not "dead", and therefore can not be
215 -- optimized away.
216 Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_1, False));
217 exception
218 when Interfaces.C.Strings.Dereference_Error =>
219 null; -- OK, expected exception.
220 when others =>
221 Report.Failed("Incorrect exception raised by Function " &
222 "Value with Terminator parameter, when " &
223 "provided a null reference");
224 end;
225
226
227 begin
228 TC_Char_Array_3 :=
229 Char_Pointers.Value(Char_Ptr,
230 Interfaces.C.ptrdiff_t(TC_Array_Size));
231 Report.Failed("Dereference_Error not raised by Function " &
232 "Value with Length parameter, when provided " &
233 "a null reference");
234 -- Call Report.Comment to ensure that the assignment to
235 -- TC_Char_Array_3 is not "dead", and therefore can not be
236 -- optimized away.
237 Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_3, False));
238 exception
239 when Interfaces.C.Strings.Dereference_Error =>
240 null; -- OK, expected exception.
241 when others =>
242 Report.Failed("Incorrect exception raised by Function " &
243 "Value with Length parameter, when " &
244 "provided a null reference");
245 end;
246
247
248 exception
249 when others => Report.Failed ("Exception raised in Test_Block");
250 end Test_Block;
251
252 Report.Result;
253
254 end CXB3014;