Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cxb/cxb4001.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 -- CXB4001.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 specifications of the package Interfaces.COBOL | |
28 -- are available for use | |
29 -- | |
30 -- TEST DESCRIPTION: | |
31 -- This test verifies that the type and the subprograms specified for | |
32 -- the interface are present. | |
33 -- | |
34 -- APPLICABILITY CRITERIA: | |
35 -- This test is applicable to all implementations that provide | |
36 -- package Interfaces.COBOL. If an implementation provides | |
37 -- package Interfaces.COBOL, this test must compile, execute, and | |
38 -- report "PASSED". | |
39 -- | |
40 -- | |
41 -- CHANGE HISTORY: | |
42 -- 06 Dec 94 SAIC ACVC 2.0 | |
43 -- 15 Nov 95 SAIC Corrected visibility errors for ACVC 2.0.1. | |
44 -- 28 Feb 96 SAIC Added applicability criteria. | |
45 -- 27 Oct 96 SAIC Incorporated reviewer comments. | |
46 -- 01 DEC 97 EDS Change "To_Comp" to "To_Binary". | |
47 --! | |
48 | |
49 with Report; | |
50 with Interfaces.COBOL; -- N/A => ERROR | |
51 | |
52 procedure CXB4001 is | |
53 | |
54 package COBOL renames Interfaces.COBOL; | |
55 use type COBOL.Byte; | |
56 use type COBOL.Decimal_Element; | |
57 | |
58 begin | |
59 | |
60 Report.Test ("CXB4001", "Check the specification of Interfaces.COBOL"); | |
61 | |
62 | |
63 declare -- encapsulate the test | |
64 | |
65 -- Types and operations for internal data representations | |
66 | |
67 TST_Floating : COBOL.Floating; | |
68 TST_Long_Floating : COBOL.Long_Floating; | |
69 | |
70 TST_Binary : COBOL.Binary; | |
71 TST_Long_Binary : COBOL.Long_Binary; | |
72 | |
73 TST_Max_Digits_Binary : constant := COBOL.Max_Digits_Binary; | |
74 TST_Max_Digits_Long_Binary : constant := COBOL.Max_Digits_Long_Binary; | |
75 | |
76 TST_Decimal_Element : COBOL.Decimal_Element; | |
77 | |
78 TST_Packed_Decimal : COBOL.Packed_Decimal (1..5) := | |
79 (others => COBOL.Decimal_Element'First); | |
80 | |
81 -- initialize it so it can reasonably be used later | |
82 TST_COBOL_Character : COBOL.COBOL_Character := | |
83 COBOL.COBOL_Character'First; | |
84 | |
85 TST_Ada_To_COBOL : COBOL.COBOL_Character := | |
86 COBOL.Ada_To_COBOL (Character'First); | |
87 | |
88 TST_COBOL_To_Ada : Character := | |
89 COBOL.COBOL_To_Ada (COBOL.COBOL_Character'First); | |
90 | |
91 -- assignment to make sure it is an array of COBOL_Character | |
92 TST_Alphanumeric : COBOL.Alphanumeric (1..5) := | |
93 (others => TST_COBOL_Character); | |
94 | |
95 | |
96 -- assignment to make sure it is an array of COBOL_Character | |
97 TST_Numeric : COBOL.Numeric (1..5) := (others => TST_COBOL_Character); | |
98 | |
99 | |
100 procedure Collect_All_Calls is | |
101 | |
102 CAC_Alphanumeric : COBOL.Alphanumeric(1..5) := | |
103 COBOL.To_COBOL("abcde"); | |
104 CAC_String : String (1..5) := "vwxyz"; | |
105 CAC_Natural : natural := 0; | |
106 | |
107 begin | |
108 | |
109 CAC_Alphanumeric := COBOL.To_COBOL (CAC_String); | |
110 CAC_String := COBOL.To_Ada (CAC_Alphanumeric); | |
111 | |
112 COBOL.To_COBOL (CAC_String, CAC_Alphanumeric, CAC_Natural); | |
113 COBOL.To_Ada (CAC_Alphanumeric, CAC_String, CAC_Natural); | |
114 | |
115 raise COBOL.Conversion_Error; | |
116 | |
117 end Collect_All_Calls; | |
118 | |
119 | |
120 | |
121 -- Formats for COBOL data representations | |
122 | |
123 TST_Unsigned : COBOL.Display_Format := COBOL.Unsigned; | |
124 TST_Leading_Separate : COBOL.Display_Format := COBOL.Leading_Separate; | |
125 TST_Trailing_Separate : COBOL.Display_Format := COBOL.Trailing_Separate; | |
126 TST_Leading_Nonseparate : COBOL.Display_Format := | |
127 COBOL.Leading_Nonseparate; | |
128 TST_Trailing_Nonseparate : COBOL.Display_Format := | |
129 COBOL.Trailing_Nonseparate; | |
130 | |
131 | |
132 TST_High_Order_First : COBOL.Binary_Format := COBOL.High_Order_First; | |
133 TST_Low_Order_First : COBOL.Binary_Format := COBOL.Low_Order_First; | |
134 TST_Native_Binary : COBOL.Binary_Format := COBOL.Native_Binary; | |
135 | |
136 | |
137 TST_Packed_Unsigned : COBOL.Packed_Format := COBOL.Packed_Unsigned; | |
138 TST_Packed_Signed : COBOL.Packed_Format := COBOL.Packed_Signed; | |
139 | |
140 | |
141 -- Types for external representation of COBOL binary data | |
142 | |
143 TST_Byte_Array : COBOL.Byte_Array(1..5) := (others => COBOL.Byte'First); | |
144 | |
145 -- Now instantiate one version of the generic | |
146 -- | |
147 type bx4001_Decimal is delta 0.1 digits 5; | |
148 package bx4001_conv is new COBOL.Decimal_Conversions (bx4001_Decimal); | |
149 | |
150 procedure Collect_All_Generic_Calls is | |
151 CAGC_natural : natural; | |
152 CAGC_Display_Format : COBOL.Display_Format; | |
153 CAGC_Boolean : Boolean; | |
154 CAGC_Numeric : COBOL.Numeric(1..5); | |
155 CAGC_Num : bx4001_Decimal; | |
156 CAGC_Packed_Decimal : COBOL.Packed_Decimal (1..5); | |
157 CAGC_Packed_Format : COBOL.Packed_Format; | |
158 CAGC_Byte_Array : COBOL.Byte_Array (1..5); | |
159 CAGC_Binary_Format : COBOL.Binary_Format; | |
160 CAGC_Binary : COBOL.Binary; | |
161 CAGC_Long_Binary : COBOL.Long_Binary; | |
162 begin | |
163 | |
164 -- Display Formats: data values are represented as Numeric | |
165 | |
166 CAGC_Boolean := bx4001_conv.Valid (CAGC_Numeric, CAGC_Display_Format); | |
167 CAGC_Natural := bx4001_conv.Length (CAGC_Display_Format); | |
168 | |
169 CAGC_Num := bx4001_conv.To_Decimal | |
170 (CAGC_Numeric, CAGC_Display_Format); | |
171 CAGC_Numeric := bx4001_conv.To_Display | |
172 (CAGC_Num, CAGC_Display_Format); | |
173 | |
174 | |
175 -- Packed Formats: data values are represented as Packed_Decimal | |
176 | |
177 CAGC_Boolean := bx4001_conv.Valid | |
178 (CAGC_Packed_Decimal, CAGC_Packed_Format); | |
179 | |
180 CAGC_Natural := bx4001_conv.Length (CAGC_Packed_Format); | |
181 | |
182 CAGC_Num := bx4001_conv.To_Decimal | |
183 (CAGC_Packed_Decimal, CAGC_Packed_Format); | |
184 | |
185 CAGC_Packed_Decimal := bx4001_conv.To_Packed | |
186 (CAGC_Num, CAGC_Packed_Format); | |
187 | |
188 | |
189 -- Binary Formats: external data values are represented as | |
190 -- Byte_Array | |
191 | |
192 CAGC_Boolean := bx4001_conv.Valid | |
193 (CAGC_Byte_Array, CAGC_Binary_Format); | |
194 | |
195 CAGC_Natural := bx4001_conv.Length (CAGC_Binary_Format); | |
196 CAGC_Num := bx4001_conv.To_Decimal | |
197 (CAGC_Byte_Array, CAGC_Binary_Format); | |
198 | |
199 CAGC_Byte_Array := bx4001_conv.To_Binary (CAGC_Num, CAGC_Binary_Format); | |
200 | |
201 | |
202 -- Internal Binary formats: data values are of type | |
203 -- Binary/Long_Binary | |
204 | |
205 CAGC_Num := bx4001_conv.To_Decimal (CAGC_Binary); | |
206 CAGC_Num := bx4001_conv.To_Decimal (CAGC_Long_Binary); | |
207 | |
208 CAGC_Binary := bx4001_conv.To_Binary (CAGC_Num); | |
209 CAGC_Long_Binary := bx4001_conv.To_Long_Binary (CAGC_Num); | |
210 | |
211 | |
212 end Collect_All_Generic_Calls; | |
213 | |
214 | |
215 begin -- encapsulation | |
216 | |
217 if COBOL.Byte'First /= 0 or | |
218 COBOL.Byte'Last /= (2 ** COBOL.COBOL_Character'Size) - 1 then | |
219 Report.Failed ("Byte is incorrectly defined"); | |
220 end if; | |
221 | |
222 if COBOL.Decimal_Element'First /= 0 then | |
223 Report.Failed ("Decimal_Element is incorrectly defined"); | |
224 end if; | |
225 | |
226 end; -- encapsulation | |
227 | |
228 Report.Result; | |
229 | |
230 end CXB4001; |