Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cxb/cxb30132.am @ 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 -- CXB30132.AM | |
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 imported, user-defined C language functions can be | |
28 -- called from an Ada program. | |
29 -- | |
30 -- TEST DESCRIPTION: | |
31 -- This test checks that user-defined C language functions can be | |
32 -- imported and referenced from an Ada program. Two C language | |
33 -- functions are specified in files CXB30130.C and CXB30131.C. | |
34 -- These two functions are imported to this test program, using two | |
35 -- calls to Pragma Import. Each function is then called in this test, | |
36 -- and the results of the call are verified. | |
37 -- | |
38 -- This test assumes that the following characters are all included | |
39 -- in the implementation defined type Interfaces.C.char: | |
40 -- ' ', 'a'..'z', and 'A'..'Z'. | |
41 -- | |
42 -- APPLICABILITY CRITERIA: | |
43 -- This test is applicable to all implementations that provide | |
44 -- packages Interfaces.C and Interfaces.C.Strings. If an | |
45 -- implementation provides packages Interfaces.C and | |
46 -- Interfaces.C.Strings, this test must compile, execute, and | |
47 -- report "PASSED". | |
48 -- | |
49 -- SPECIAL REQUIREMENTS: | |
50 -- The files CXB30130.C and CXB30131.C must be compiled with a C | |
51 -- compiler. Implementation dialects of C may require alteration of | |
52 -- the C program syntax (see individual C files). | |
53 -- | |
54 -- Note that the compiled C code must be bound with the compiled Ada | |
55 -- code to create an executable image. An implementation must provide | |
56 -- the necessary commands to accomplish this. | |
57 -- | |
58 -- Note that the C code included in CXB30130.C and CXB30131.C conforms | |
59 -- to ANSI-C. Modifications to these files may be required for other | |
60 -- C compilers. An implementation must provide the necessary | |
61 -- modifications to satisfy the function requirements. | |
62 -- | |
63 -- TEST FILES: | |
64 -- The following files comprise this test: | |
65 -- | |
66 -- CXB30130.C | |
67 -- CXB30131.C | |
68 -- CXB30132.AM | |
69 -- | |
70 -- | |
71 -- CHANGE HISTORY: | |
72 -- 13 Oct 95 SAIC Initial prerelease version. | |
73 -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. | |
74 -- 26 Oct 96 SAIC Incorporated reviewer comments. | |
75 -- | |
76 --! | |
77 | |
78 with Report; | |
79 with Impdef; | |
80 with Interfaces.C; -- N/A => ERROR | |
81 with Interfaces.C.Strings; -- N/A => ERROR | |
82 | |
83 procedure CXB30132 is | |
84 begin | |
85 | |
86 Report.Test ("CXB3013", "Check that user-defined C functions can " & | |
87 "be imported into an Ada program"); | |
88 | |
89 Test_Block: | |
90 declare | |
91 | |
92 package IC renames Interfaces.C; | |
93 package ICS renames Interfaces.C.Strings; | |
94 | |
95 use type IC.char_array; | |
96 use type IC.int; | |
97 use type IC.short; | |
98 use type IC.C_float; | |
99 use type IC.double; | |
100 | |
101 type Short_Ptr is access all IC.short; | |
102 type Float_Ptr is access all IC.C_float; | |
103 type Double_Ptr is access all IC.double; | |
104 subtype Char_Array_Type is IC.char_array(0..20); | |
105 | |
106 TC_Default_int : IC.int := 49; | |
107 TC_Default_short : IC.short := 3; | |
108 TC_Default_float : IC.C_float := 50.0; | |
109 TC_Default_double : IC.double := 1209.0; | |
110 | |
111 An_Int_Value : IC.int := TC_Default_int; | |
112 A_Short_Value : aliased IC.short := TC_Default_short; | |
113 A_Float_Value : aliased IC.C_float := TC_Default_float; | |
114 A_Double_Value : aliased IC.double := TC_Default_double; | |
115 | |
116 A_Short_Int_Pointer : Short_Ptr := A_Short_Value'access; | |
117 A_Float_Pointer : Float_Ptr := A_Float_Value'access; | |
118 A_Double_Pointer : Double_Ptr := A_Double_Value'access; | |
119 | |
120 Char_Array_1 : Char_Array_Type; | |
121 Char_Array_2 : Char_Array_Type; | |
122 Char_Pointer : ICS.chars_ptr; | |
123 | |
124 TC_Char_Array : constant Char_Array_Type := | |
125 "Look before you leap" & IC.nul; | |
126 TC_Return_int : IC.int := 0; | |
127 | |
128 -- The Square_It function returns the square of the value The_Int | |
129 -- through the function name, and returns the square of the other | |
130 -- parameters through the parameter list (the last three parameters | |
131 -- are access values). | |
132 | |
133 function Square_It (The_Int : in IC.int; | |
134 The_Short : in Short_Ptr; | |
135 The_Float : in Float_Ptr; | |
136 The_Double : in Double_Ptr) return IC.int; | |
137 | |
138 -- The Combine_Strings function returns the result of the catenation | |
139 -- of the two string parameters through the function name. | |
140 | |
141 function Combine_Strings (First_Part : in IC.char_array; | |
142 Second_Part : in IC.char_array) | |
143 return ICS.chars_ptr; | |
144 | |
145 | |
146 -- Use the user-defined C function square_it as a completion to the | |
147 -- function specification above. | |
148 | |
149 pragma Import (Convention => C, | |
150 Entity => Square_It, | |
151 External_Name => Impdef.CXB30130_External_Name); | |
152 | |
153 -- Use the user-defined C function combine_two_strings as a completion | |
154 -- to the function specification above. | |
155 | |
156 pragma Import (C, Combine_Strings, Impdef.CXB30131_External_Name); | |
157 | |
158 | |
159 begin | |
160 | |
161 -- Check that the imported version of C function CXB30130 produces | |
162 -- the correct results. | |
163 | |
164 TC_Return_int := Square_It (The_Int => An_Int_Value, | |
165 The_Short => A_Short_Int_Pointer, | |
166 The_Float => A_Float_Pointer, | |
167 The_Double => A_Double_Pointer); | |
168 | |
169 -- Compare the results with the expected results. Note that in the | |
170 -- case of the three "pointer" parameters, the objects being pointed | |
171 -- to have been modified as a result of the function. | |
172 | |
173 if TC_Return_int /= An_Int_Value * An_Int_Value or | |
174 A_Short_Int_Pointer.all /= TC_Default_short * TC_Default_Short or | |
175 A_Short_Value /= TC_Default_short * TC_Default_Short or | |
176 A_Float_Pointer.all /= TC_Default_float * TC_Default_float or | |
177 A_Float_Value /= TC_Default_float * TC_Default_float or | |
178 A_Double_Pointer.all /= TC_Default_double * TC_Default_double or | |
179 A_Double_Value /= TC_Default_double * TC_Default_double | |
180 then | |
181 Report.Failed("Incorrect results returned from function square_it"); | |
182 end if; | |
183 | |
184 | |
185 -- Check that two char_array values are combined by the imported | |
186 -- C function CXB30131. | |
187 | |
188 Char_Array_1(0..12) := "Look before " & IC.nul; | |
189 Char_Array_2(0..8) := "you leap" & IC.nul; | |
190 | |
191 Char_Pointer := Combine_Strings (Char_Array_1, Char_Array_2); | |
192 | |
193 if ICS.Value(Char_Pointer) /= TC_Char_Array then | |
194 Report.Failed("Incorrect value returned from imported function " & | |
195 "combine_two_strings"); | |
196 end if; | |
197 | |
198 | |
199 exception | |
200 when others => Report.Failed ("Exception raised in Test_Block"); | |
201 end Test_Block; | |
202 | |
203 Report.Result; | |
204 | |
205 end CXB30132; |