Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/cxh/cxh3002.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 -- CXH3002.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 pragma Inspection_Point is allowed whereever a declarative
28 -- item or statement is allowed. Check that pragma Inspection_Point may
29 -- have zero or more arguments. Check that the execution of pragma
30 -- Inspection_Point has no effect.
31 --
32 -- TEST DESCRIPTION
33 -- Check pragma Inspection_Point applied to:
34 -- A no objects,
35 -- B one object,
36 -- C multiple objects.
37 -- Check pragma Inspection_Point applied to:
38 -- D Enumeration type objects,
39 -- E Integer type objects (signed and unsigned),
40 -- F access type objects,
41 -- G Floating Point type objects,
42 -- H Fixed point type objects,
43 -- I array type objects,
44 -- J record type objects,
45 -- K tagged type objects,
46 -- L protected type objects,
47 -- M controlled type objects,
48 -- N task type objects.
49 -- Check pragma Inspection_Point applied in:
50 -- O declarations (package, procedure)
51 -- P statements (incl package elaboration)
52 -- Q subprogram (procedure, function, finalization)
53 -- R package
54 -- S specification
55 -- T body (PO entry, task body, loop body, accept body, select body)
56 -- U task
57 -- V protected object
58 --
59 --
60 -- APPLICABILITY CRITERIA:
61 -- This test is only applicable for a compiler attempting validation
62 -- for the Safety and Security Annex.
63 --
64 --
65 -- CHANGE HISTORY:
66 -- 26 OCT 95 SAIC Initial version
67 -- 12 NOV 96 SAIC Revised for 2.1
68 --
69 --!
70
71 ----------------------------------------------------------------- CXH3002_0
72
73 package CXH3002_0 is
74
75 type Enum is (Item,Stuff,Things);
76
77 type Int is range 0..256;
78
79 type Unt is mod 256;
80
81 type Flt is digits 5;
82
83 type Fix is delta 0.5 range -1.0..1.0;
84
85 type Root(Disc: Enum) is record
86 I: Int;
87 U: Unt;
88 end record;
89
90 type List is array(Unt) of Root(Stuff);
91
92 type A_List is access all List;
93 type A_Proc is access procedure(R:Root);
94
95 procedure Proc(R:Root);
96 function Func return A_Proc;
97
98 protected type PT is
99 entry Prot_Entry(Switch: Boolean);
100 private
101 Toggle : Boolean := False;
102 end PT;
103
104 task type TT is
105 entry Task_Entry(Items: in A_List);
106 end TT;
107
108 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
109 pragma Inspection_Point; -- AORS
110 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
111
112 end CXH3002_0;
113
114 ----------------------------------------------------------------- CXH3002_1
115
116 with Ada.Finalization;
117 package CXH3002_0.CXH3002_1 is
118
119 type Final is new Ada.Finalization.Controlled with
120 record
121 Value : Natural;
122 end record;
123
124 procedure Initialize( F: in out Final );
125 procedure Adjust( F: in out Final );
126 procedure Finalize( F: in out Final );
127
128 end CXH3002_0.CXH3002_1;
129
130 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_0
131
132 package body CXH3002_0 is
133
134 Global_Variable : Character := 'A';
135
136 procedure Proc(R:Root) is
137 begin
138 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
139 pragma Inspection_Point( Global_Variable ); -- BDPQT
140 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
141 case R.Disc is
142 when Item => Global_Variable := 'I';
143 when Stuff => Global_Variable := 'S';
144 when Things => Global_Variable := 'T';
145 end case;
146 end Proc;
147
148 function Func return A_Proc is
149 begin
150 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
151 pragma Inspection_Point; -- APQT
152 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
153 return Proc'Access;
154 end Func;
155
156 protected body PT is
157 entry Prot_Entry(Switch: Boolean) when True is
158 begin
159 Toggle := Switch;
160 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
161 pragma Inspection_Point; -- APVT
162 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
163 end Prot_Entry;
164 end PT;
165
166 task body TT is
167 List_Copy : A_List;
168 begin
169 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
170 pragma Inspection_Point; -- APUT
171 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
172 loop
173 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
174 pragma Inspection_Point; -- APUT
175 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
176 select
177 accept Task_Entry(Items: in A_List) do
178 List_Copy := Items;
179 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
180 pragma Inspection_Point( List_Copy ); -- BFPUT
181 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
182 end Task_Entry;
183 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
184 pragma Inspection_Point; -- APUT
185 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
186 or terminate;
187 end select;
188 end loop;
189 end TT;
190
191 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
192 pragma Inspection_Point; -- ARTO
193 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
194
195 end CXH3002_0;
196
197 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_1
198
199 with Report;
200 package body CXH3002_0.CXH3002_1 is
201
202 Embedded_Final_Object : Final
203 := (Ada.Finalization.Controlled with Value => 1);
204 -- attempt to call Initialize here would P_E!
205
206 procedure Initialize( F: in out Final ) is
207 begin
208 F.Value := 1;
209 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
210 pragma Inspection_Point( Embedded_Final_Object ); -- BKQP
211 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
212 end Initialize;
213
214 procedure Adjust( F: in out Final ) is
215 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
216 pragma Inspection_Point; -- AQO
217 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
218 begin
219 F.Value := 2;
220 end Adjust;
221
222 procedure Finalize( F: in out Final ) is
223 begin
224 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
225 pragma Inspection_Point; -- AQP
226 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
227 if F.Value not in 1..10 then
228 Report.Failed("Bad value in controlled object at finalization");
229 end if;
230 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
231 pragma Inspection_Point; -- AQP
232 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
233 end Finalize;
234
235 begin
236 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---======
237 pragma Inspection_Point( Embedded_Final_Object ); -- BKRTP
238 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---======
239 null;
240 end CXH3002_0.CXH3002_1;
241
242 ------------------------------------------------------------------- CXH3002
243
244 with Report;
245 with CXH3002_0.CXH3002_1;
246 procedure CXH3002 is
247
248 use type CXH3002_0.Enum, CXH3002_0.Int, CXH3002_0.Unt, CXH3002_0.Flt,
249 CXH3002_0.Fix, CXH3002_0.Root;
250
251 Main_Enum : CXH3002_0.Enum := CXH3002_0.Item;
252 Main_Int : CXH3002_0.Int;
253 Main_Unt : CXH3002_0.Unt;
254 Main_Flt : CXH3002_0.Flt;
255 Main_Fix : CXH3002_0.Fix;
256 Main_Rec : CXH3002_0.Root(CXH3002_0.Stuff)
257 := (CXH3002_0.Stuff, I => 1, U => 2);
258
259 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
260 pragma Inspection_Point( Main_Rec ); -- BJQO
261 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
262
263 Main_List : CXH3002_0.List := ( others => Main_Rec );
264
265 Main_A_List : CXH3002_0.A_List := new CXH3002_0.List'( others => Main_Rec );
266 Main_A_Proc : CXH3002_0.A_Proc := CXH3002_0.Func;
267 -- CXH3002_0.Proc'Access
268 Main_PT : CXH3002_0.PT;
269 Main_TT : CXH3002_0.TT;
270
271 type Test_Range is (First, Second);
272
273 procedure Assert( Truth : Boolean; Message : String ) is
274 begin
275 if not Truth then
276 Report.Failed( "Unexpected value found in " & Message );
277 end if;
278 end Assert;
279
280 begin -- Main test procedure.
281
282 Report.Test ("CXH3002", "Check pragma Inspection_Point" );
283
284 Enclosure:declare
285 Main_Final : CXH3002_0.CXH3002_1.Final;
286 Xtra_Final : CXH3002_0.CXH3002_1.Final;
287 begin
288 for Test_Case in Test_Range loop
289
290
291 case Test_Case is
292 when First =>
293 Main_Final.Value := 5;
294 Xtra_Final := Main_Final; -- call Adjust
295 Main_Enum := CXH3002_0.Things;
296 Main_Int := CXH3002_0.Int'First;
297 Main_Unt := CXH3002_0.Unt'Last;
298 Main_Flt := 3.14;
299 Main_Fix := 0.5;
300 Main_Rec := (CXH3002_0.Stuff, I => 3, U => 4);
301 Main_List(Main_Unt) := Main_Rec;
302 Main_A_List(CXH3002_0.Unt'First) := (CXH3002_0.Stuff, I => 5, U => 6);
303 Main_A_Proc( Main_A_List(2) );
304 Main_PT.Prot_Entry(True);
305 Main_TT.Task_Entry( null );
306
307 when Second =>
308 Assert( Main_Final.Value = 5, "Main_Final" );
309 Assert( Xtra_Final.Value = 2, "Xtra_Final" );
310 Assert( Main_Enum = CXH3002_0.Things, "Main_Enum" );
311 Assert( Main_Int = CXH3002_0.Int'First, "Main_Int" );
312 Assert( Main_Unt = CXH3002_0.Unt'Last, "Main_Unt" );
313 Assert( Main_Flt in 3.0..3.5, "Main_Flt" );
314 Assert( Main_Fix = 0.5, "Main_Fix" );
315 Assert( Main_Rec = (CXH3002_0.Stuff, I => 3, U => 4), "Main_Rec" );
316 Assert( Main_List(Main_Unt) = Main_Rec, "Main_List" );
317 Assert( Main_A_List(CXH3002_0.Unt'First)
318 = (CXH3002_0.Stuff, I => 5, U => 6), "Main_A_List" );
319
320 end case;
321
322 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==
323 pragma Inspection_Point( -- CQP
324 Main_Final, -- M
325 Main_Enum, -- D
326 Main_Int, -- E
327 Main_Unt, -- E
328 Main_Flt, -- G
329 Main_Fix, -- H
330 Main_Rec, -- J
331 Main_List, -- I
332 Main_A_List, -- F
333 Main_A_Proc, -- F
334 Main_PT, -- L
335 Main_TT ); -- N
336 -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==
337
338 end loop;
339 end Enclosure;
340
341 Report.Result;
342
343 end CXH3002;