3 -- Grant of Unlimited Rights
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
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.
27 -- Check that the Procedure Free resets the parameter Item to
28 -- Null_Ptr. Check that Free has no effect if Item is Null_Ptr.
30 -- Check that the version of Function Value with a chars_ptr parameter
31 -- returning a char_array result returns the prefix of an array of
34 -- Check that the version of Function Value with a chars_ptr parameter
35 -- and a size_t parameter returning a char_array result returns
37 -- 1) the first size_t number of characters, or
38 -- 2) the characters up to and including the first nul.
40 -- Check that both of the above versions of Function Value propagate
41 -- Dereference_Error if the Item parameter is Null_Ptr.
44 -- This test validates the Procedure Free and two versions of Function
45 -- Value. A variety of char_array and char_ptr values are provided as
46 -- input, and results are compared for both length and content.
48 -- This test assumes that the following characters are all included
49 -- in the implementation defined type Interfaces.C.char:
50 -- ' ', 'a'..'z', and 'A'..'Z'.
52 -- APPLICABILITY CRITERIA:
53 -- This test is applicable to all implementations that provide
54 -- package Interfaces.C.Strings. If an implementation provides
55 -- package Interfaces.C.Strings, this test must compile, execute,
56 -- and report "PASSED".
60 -- 27 Sep 95 SAIC Initial prerelease version.
61 -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
62 -- 26 Oct 96 SAIC Incorporated reviewer comments.
63 -- 01 DEC 97 EDS Replicate line 199 at line 256, to ensure that
64 -- TC_chars_ptr has a valid pointer.
65 -- 08 JUL 99 RLB Added a test case to check that Value raises
66 -- Constraint_Error when Length = 0. (From Technical
68 -- 25 JAN 01 RLB Repaired previous test case to avoid raising
69 -- Constraint_Error in test case code.
70 -- 26 JAN 01 RLB Added an Ident_Int to the test case to prevent
76 with Interfaces
.C
.Strings
; -- N/A => ERROR
81 Report
.Test
("CXB3010", "Check that Procedure Free and versions of " &
82 "Function Value produce correct results");
87 package IC
renames Interfaces
.C
;
88 package ICS
renames Interfaces
.C
.Strings
;
90 use type IC
.char_array
;
92 use type ICS
.chars_ptr
;
95 Null_Char_Array_Access
: constant ICS
.char_array_access
:= null;
97 TC_String_1
: constant String := "Nonul";
98 TC_String_2
: constant String := "AbCdE";
99 TC_Blank_String
: constant String(1..5) := (others => ' ');
101 -- The initialization of the following char_array objects
102 -- includes the appending of a terminating nul char, in order to
103 -- prevent the erroneous execution of Function Value.
105 TC_char_array
: IC
.char_array
:=
106 IC
.To_C
(TC_Blank_String
, True);
107 TC_char_array_1
: constant IC
.char_array
:=
108 IC
.To_C
(TC_String_1
, True);
109 TC_char_array_2
: constant IC
.char_array
:=
110 IC
.To_C
(TC_String_2
, True);
111 TC_Blank_char_array
: constant IC
.char_array
:=
112 IC
.To_C
(TC_Blank_String
, True);
114 -- This chars_ptr is initialized via the use of New_Chars_Array to
115 -- avoid erroneous execution of procedure Free.
116 TC_chars_ptr
: ICS
.chars_ptr
:=
117 ICS
.New_Char_Array
(TC_Blank_char_array
);
121 -- Check that the Procedure Free resets the parameter Item
124 if TC_chars_ptr
= ICS
.Null_Ptr
then
125 Report
.Failed
("TC_chars_ptr is currently null; it should not be " &
126 "null since it was given default initialization");
129 ICS
.Free
(TC_chars_ptr
);
131 if TC_chars_ptr
/= ICS
.Null_Ptr
then
132 Report
.Failed
("TC_chars_ptr was not set to Null_Ptr by " &
136 -- Check that Free has no effect if Item is Null_Ptr.
139 TC_chars_ptr
:= ICS
.Null_Ptr
; -- Ensure pointer is null.
140 ICS
.Free
(TC_chars_ptr
);
141 if TC_chars_ptr
/= ICS
.Null_Ptr
then
142 Report
.Failed
("TC_chars_ptr was set to a non-Null_Ptr value " &
143 "by Procedure Free. It was provided as a null " &
144 "parameter to Free, and there should have been " &
145 "no effect from a call to Procedure Free");
149 Report
.Failed
("Unexpected exception raised by Procedure Free " &
150 "when parameter Item is Null_Ptr");
154 -- Check that the version of Function Value with a chars_ptr parameter
155 -- that returns a char_array result returns an array of chars (up to
156 -- and including the first nul).
158 TC_chars_ptr
:= ICS
.New_Char_Array
(TC_char_array_1
);
159 TC_char_array
:= ICS
.Value
(Item
=> TC_chars_ptr
);
161 if TC_char_array
/= TC_char_array_1
or
162 IC
.To_Ada
(TC_char_array
, True) /= IC
.To_Ada
(TC_char_array_1
)
164 Report
.Failed
("Incorrect result from Function Value - 1");
167 TC_chars_ptr
:= ICS
.New_Char_Array
(TC_char_array_2
);
168 TC_char_array
:= ICS
.Value
(Item
=> TC_chars_ptr
);
170 if TC_char_array
/= TC_char_array_2
or
171 IC
.To_Ada
(TC_char_array
, True) /= IC
.To_Ada
(TC_char_array_2
)
173 Report
.Failed
("Incorrect result from Function Value - 2");
176 if ICS
.Value
(Item
=> ICS
.New_String
("A little longer string")) /=
177 IC
.To_C
("A little longer string")
179 Report
.Failed
("Incorrect result from Function Value - 3");
183 -- Check that the version of Function Value with a chars_ptr parameter
184 -- and a size_t parameter that returns a char_array result returns
186 -- 1) the first size_t number of characters, or
187 -- 2) the characters up to and including the first nul.
189 -- Case 1: the first size_t number of characters (less than the
193 TC_chars_ptr
:= ICS
.New_Char_Array
(TC_char_array_1
);
194 TC_char_array
(0..2) := ICS
.Value
(Item
=> TC_chars_ptr
, Length
=> 3);
196 if TC_char_array
(0..2) /= TC_char_array_1
(0..2)
199 ("Incorrect result from Function Value with Length " &
204 Report
.Failed
("Exception raised during Case 1 evaluation");
207 -- Case 2: the characters up to and including the first nul.
209 TC_chars_ptr
:= ICS
.New_Char_Array
(TC_char_array_2
);
211 -- The length supplied as a parameter exceeds the total length of
212 -- TC_char_array_2. The result should be the entire TC_char_array_2
213 -- including the terminating nul.
215 TC_char_array
:= ICS
.Value
(Item
=> TC_chars_ptr
, Length
=> 7);
217 if TC_char_array
/= TC_char_array_2
or
218 IC
.To_Ada
(TC_char_array
) /= IC
.To_Ada
(TC_char_array_2
) or
219 not (IC
.Is_Nul_Terminated
(TC_char_array
))
221 Report
.Failed
("Incorrect result from Function Value with Length " &
226 -- Check that both of the above versions of Function Value propagate
227 -- Dereference_Error if the Item parameter is Null_Ptr.
231 -- Declare a dummy function to demonstrate one way that a chars_ptr
232 -- variable could inadvertantly be set to Null_Ptr prior to a call
234 function Freedom
(Condition
: Boolean := False;
235 Ptr
: ICS
.chars_ptr
) return ICS
.chars_ptr
is
236 Pointer
: ICS
.chars_ptr
:= Ptr
;
241 null; -- An activity that doesn't set the chars_ptr value to
250 TC_char_array
:= ICS
.Value
(Item
=> Freedom
(True, TC_chars_ptr
));
252 ("Function Value (without Length parameter) did not " &
253 "raise Dereference_Error when provided a null Item " &
254 "parameter input value");
255 if TC_char_array
(0) = '6' then -- Defeat optimization.
256 Report
.Comment
("Should never be printed");
259 when ICS
.Dereference_Error
=> null; -- OK, expected exception.
261 Report
.Failed
("Incorrect exception raised by Function Value " &
262 "with Item parameter, when the Item parameter " &
266 TC_chars_ptr
:= ICS
.New_Char_Array
(TC_char_array_2
);
268 TC_char_array
:= ICS
.Value
(Item
=> Freedom
(True, TC_chars_ptr
),
271 ("Function Value (with Length parameter) did not " &
272 "raise Dereference_Error when provided a null Item " &
273 "parameter input value");
274 if TC_char_array
(0) = '6' then -- Defeat optimization.
275 Report
.Comment
("Should never be printed");
278 when ICS
.Dereference_Error
=> null; -- OK, expected exception.
280 Report
.Failed
("Incorrect exception raised by Function Value " &
281 "with both Item and Length parameters, when " &
282 "the Item parameter is Null_Ptr");
286 -- Check that Function Value with two parameters propagates
287 -- Constraint_Error if Length is 0.
290 TC_chars_ptr
:= ICS
.New_Char_Array
(TC_char_array_1
);
292 TC
: IC
.char_array
:= ICS
.Value
(Item
=> TC_chars_ptr
, Length
=>
293 IC
.Size_T
(Report
.Ident_Int
(0)));
296 ("Function Value (with Length parameter) did not " &
297 "raise Constraint_Error when Length = 0");
298 if TC
'Length <= TC_char_array
'Length then
299 TC_char_array
(1..TC
'Length) := TC
; -- Block optimization of TC.
304 ("Function Value (with Length parameter) did not " &
305 "raise Constraint_Error when Length = 0");
307 when Constraint_Error
=> null; -- OK, expected exception.
309 Report
.Failed
("Incorrect exception raised by Function Value " &
310 "with both Item and Length parameters, when " &
315 when others => Report
.Failed
("Exception raised in Test_Block");