Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cxb/cxb4002.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 -- CXB4002.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_COBOL converts the character elements
28 -- of the String parameter Item into COBOL_Character elements of the
29 -- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping
30 -- as the basis of conversion.
31 -- Check that the parameter Last contains the index of the last element
32 -- of parameter Target that was assigned by To_COBOL.
33 --
34 -- Check that Constraint_Error is propagated by procedure To_COBOL
35 -- when the length of String parameter Item exceeds the length of
36 -- Alphanumeric parameter Target.
37 --
38 -- Check that the procedure To_Ada converts the COBOL_Character
39 -- elements of the Alphanumeric parameter Item into Character elements
40 -- of the String parameter Target, using the COBOL_to_Ada mapping array
41 -- as the basis of conversion.
42 -- Check that the parameter Last contains the index of the last element
43 -- of parameter Target that was assigned by To_Ada.
44 --
45 -- Check that Constraint_Error is propagated by procedure To_Ada when
46 -- the length of Alphanumeric parameter Item exceeds the length of
47 -- String parameter Target.
48 --
49 -- TEST DESCRIPTION:
50 -- This test checks that the procedures To_COBOL and To_Ada produce
51 -- the correct results, based on a variety of parameter input values.
52 --
53 -- In the first series of subtests, the Out parameter results of
54 -- procedure To_COBOL are compared against expected results,
55 -- which includes (in the parameter Last) the index in Target of the
56 -- last element assigned. The situation where procedure To_COBOL raises
57 -- Constraint_Error (when Item'Length exceeds Target'Length) is also
58 -- verified.
59 --
60 -- In the second series of subtests, the Out parameter results of
61 -- procedure To_Ada are verified, in a similar manner as is done for
62 -- procedure To_COBOL. The case of procedure To_Ada raising
63 -- Constraint_Error is also verified.
64 --
65 -- This test assumes that the following characters are all included
66 -- in the implementation defined type Interfaces.COBOL.COBOL_Character:
67 -- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', '$', '-', '_', and '#'.
68 --
69 -- APPLICABILITY CRITERIA:
70 -- This test is applicable to all implementations that provide
71 -- package Interfaces.COBOL. If an implementation provides
72 -- package Interfaces.COBOL, this test must compile, execute, and
73 -- report "PASSED".
74 --
75 --
76 -- CHANGE HISTORY:
77 -- 12 Jan 96 SAIC Initial prerelease version.
78 -- 30 May 96 SAIC Added applicability criteria for ACVC 2.1.
79 -- 27 Oct 96 SAIC Incorporated reviewer comments.
80 --
81 --!
82
83 with Report;
84 with Ada.Strings.Bounded;
85 with Ada.Strings.Unbounded;
86 with Interfaces.COBOL; -- N/A => ERROR
87
88 procedure CXB4002 is
89 begin
90
91 Report.Test ("CXB4002", "Check that the procedures To_COBOL and " &
92 "To_Ada produce correct results");
93
94 Test_Block:
95 declare
96
97 package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10);
98 package Unb renames Ada.Strings.Unbounded;
99
100 use Interfaces;
101 use Bnd, Unb;
102 use type Interfaces.COBOL.Alphanumeric;
103
104
105 Alphanumeric_1 : COBOL.Alphanumeric(1..1) := " ";
106 Alphanumeric_5 : COBOL.Alphanumeric(1..5) := " ";
107 Alphanumeric_10 : COBOL.Alphanumeric(1..10) := " ";
108 Alphanumeric_20 : COBOL.Alphanumeric(1..20) := " ";
109 TC_Alphanumeric_1 : COBOL.Alphanumeric(1..1) := "A";
110 TC_Alphanumeric_5 : COBOL.Alphanumeric(1..5) := "ab*de";
111 TC_Alphanumeric_10 : COBOL.Alphanumeric(1..10) := "$1a2b3C4D5";
112 TC_Alphanumeric_20 : COBOL.Alphanumeric(1..20) := "1234-ABCD_6789#fghij";
113
114 Bnd_String : Bnd.Bounded_String :=
115 Bnd.To_Bounded_String(" ");
116 TC_Bnd_String : Bounded_String :=
117 To_Bounded_String("$1a2b3C4D5");
118
119 Unb_String : Unb.Unbounded_String :=
120 Unb.To_Unbounded_String(" ");
121 TC_Unb_String : Unbounded_String :=
122 To_Unbounded_String("ab*de");
123
124 String_1 : String(1..1) := " ";
125 String_5 : String(1..5) := " ";
126 String_10 : String(1..10) := " ";
127 String_20 : String(1..20) := " ";
128 TC_String_1 : String(1..1) := "A";
129 TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij";
130
131 TC_Alphanumeric : constant COBOL.Alphanumeric := ""; -- null array.
132 TC_String : constant String := ""; -- null string.
133 TC_Natural : Natural := 0;
134
135
136 begin
137
138 -- Check that the procedure To_COBOL converts the character elements
139 -- of the String parameter Item into COBOL_Character elements of the
140 -- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping
141 -- as the basis of conversion.
142 -- Check that the parameter Last contains the index of the last element
143 -- of parameter Target that was assigned by To_COBOL.
144
145 COBOL.To_COBOL(Item => TC_String_1,
146 Target => Alphanumeric_1,
147 Last => TC_Natural);
148
149 if Alphanumeric_1 /= TC_Alphanumeric_1 or
150 TC_Natural /= TC_Alphanumeric_1'Length or
151 TC_Natural /= 1
152 then
153 Report.Failed("Incorrect result from procedure To_COBOL - 1");
154 end if;
155
156 COBOL.To_COBOL(To_String(TC_Unb_String),
157 Target => Alphanumeric_5,
158 Last => TC_Natural);
159
160 if Alphanumeric_5 /= TC_Alphanumeric_5 or
161 TC_Natural /= TC_Alphanumeric_5'Length or
162 TC_Natural /= 5
163 then
164 Report.Failed("Incorrect result from procedure To_COBOL - 2");
165 end if;
166
167 COBOL.To_COBOL(To_String(TC_Bnd_String),
168 Alphanumeric_10,
169 Last => TC_Natural);
170
171 if Alphanumeric_10 /= TC_Alphanumeric_10 or
172 TC_Natural /= TC_Alphanumeric_10'Length or
173 TC_Natural /= 10
174 then
175 Report.Failed("Incorrect result from procedure To_COBOL - 3");
176 end if;
177
178 COBOL.To_COBOL(TC_String_20,
179 Alphanumeric_20,
180 TC_Natural);
181
182 if Alphanumeric_20 /= TC_Alphanumeric_20 or
183 TC_Natural /= TC_Alphanumeric_20'Length or
184 TC_Natural /= 20
185 then
186 Report.Failed("Incorrect result from procedure To_COBOL - 4");
187 end if;
188
189 COBOL.To_COBOL(Item => TC_String, -- null string
190 Target => Alphanumeric_1,
191 Last => TC_Natural);
192
193 if TC_Natural /= 0 then
194 Report.Failed("Incorrect result from procedure To_COBOL, value " &
195 "returned in parameter Last should be zero, since " &
196 "parameter Item is null array");
197 end if;
198
199
200
201 -- Check that Constraint_Error is propagated by procedure To_COBOL
202 -- when the length of String parameter Item exceeds the length of
203 -- Alphanumeric parameter Target.
204
205 begin
206
207 COBOL.To_COBOL(Item => TC_String_20,
208 Target => Alphanumeric_10,
209 Last => TC_Natural);
210 Report.Failed("Constraint_Error not raised by procedure To_COBOL " &
211 "when Item'Length exceeds Target'Length");
212 exception
213 when Constraint_Error => null; -- OK, expected exception.
214 when others =>
215 Report.Failed("Incorrect exception raised by procedure To_COBOL " &
216 "when Item'Length exceeds Target'Length");
217 end;
218
219
220 -- Check that the procedure To_Ada converts the COBOL_Character
221 -- elements of the Alphanumeric parameter Item into Character elements
222 -- of the String parameter Target, using the COBOL_to_Ada mapping array
223 -- as the basis of conversion.
224 -- Check that the parameter Last contains the index of the last element
225 -- of parameter Target that was assigned by To_Ada.
226
227 COBOL.To_Ada(Item => TC_Alphanumeric_1,
228 Target => String_1,
229 Last => TC_Natural);
230
231 if String_1 /= TC_String_1 or
232 TC_Natural /= TC_String_1'Length or
233 TC_Natural /= 1
234 then
235 Report.Failed("Incorrect result from procedure To_Ada - 1");
236 end if;
237
238 COBOL.To_Ada(TC_Alphanumeric_5,
239 Target => String_5,
240 Last => TC_Natural);
241
242 if String_5 /= To_String(TC_Unb_String) or
243 TC_Natural /= Length(TC_Unb_String) or
244 TC_Natural /= 5
245 then
246 Report.Failed("Incorrect result from procedure To_Ada - 2");
247 end if;
248
249 COBOL.To_Ada(TC_Alphanumeric_10,
250 String_10,
251 Last => TC_Natural);
252
253 if String_10 /= To_String(TC_Bnd_String) or
254 TC_Natural /= Length(TC_Bnd_String) or
255 TC_Natural /= 10
256 then
257 Report.Failed("Incorrect result from procedure To_Ada - 3");
258 end if;
259
260 COBOL.To_Ada(TC_Alphanumeric_20,
261 String_20,
262 TC_Natural);
263
264 if String_20 /= TC_String_20 or
265 TC_Natural /= TC_String_20'Length or
266 TC_Natural /= 20
267 then
268 Report.Failed("Incorrect result from procedure To_Ada - 4");
269 end if;
270
271 COBOL.To_Ada(Item => TC_Alphanumeric, -- null array.
272 Target => String_20,
273 Last => TC_Natural);
274
275 if TC_Natural /= 0 then
276 Report.Failed("Incorrect result from procedure To_Ada, value " &
277 "returned in parameter Last should be zero, since " &
278 "parameter Item is null array");
279 end if;
280
281
282
283 -- Check that Constraint_Error is propagated by procedure To_Ada when
284 -- the length of Alphanumeric parameter Item exceeds the length of
285 -- String parameter Target.
286
287 begin
288
289 COBOL.To_Ada(Item => TC_Alphanumeric_10,
290 Target => String_5,
291 Last => TC_Natural);
292 Report.Failed("Constraint_Error not raised by procedure To_Ada " &
293 "when Item'Length exceeds Target'Length");
294 exception
295 when Constraint_Error => null; -- OK, expected exception.
296 when others =>
297 Report.Failed("Incorrect exception raised by procedure To_Ada " &
298 "when Item'Length exceeds Target'Length");
299 end;
300
301
302 exception
303 when others => Report.Failed ("Exception raised in Test_Block");
304 end Test_Block;
305
306 Report.Result;
307
308 end CXB4002;