Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c391001.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 -- C391001.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 structures nesting discriminated records as
28 -- components in record extension are correctly supported. Check
29 -- for this using limited private structures.
30 -- Check that record extensions inherit all the visible components
31 -- of their ancestor types.
32 -- Check that discriminants are correctly inherited.
33 --
34 -- TEST DESCRIPTION:
35 -- This test defines a textbook object, a serial number plaque.
36 -- This object is used in each of several other structures modeled
37 -- after those used in an existing antenna modeling software system.
38 -- Record types discriminated and undiscriminated are nested to
39 -- produce a layered design. Some parametrization is programmatic;
40 -- some parametrization is data-driven.
41 --
42 --
43 --
44 -- CHANGE HISTORY:
45 -- 06 Dec 94 SAIC ACVC 2.0
46 -- 19 Dec 94 SAIC Removed RM references from objective text.
47 -- 19 Apr 95 SAIC Added "limited" to full type def of "Object"
48 --
49 --!
50
51 package C391001_1 is
52 type Object is tagged limited private;
53 -- Constructor operation
54 procedure Create( The_Plaque : in out Object );
55 -- Selector operations
56 function "="( Left_Plaque,Right_Plaque : Object ) return Boolean;
57 function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
58 return Boolean;
59 function Serial_Number( A_Plaque : Object ) return Natural;
60 Unserialized : exception; -- Serial_Number called before Create
61 Reserialized : exception; -- Create called twice
62 private
63 type Object is tagged limited record
64 Serial_Number : Natural := 0;
65 end record;
66 end C391001_1;
67
68 package body C391001_1 is
69 Counter : Natural := 0;
70 procedure Create( The_Plaque : in out Object ) is
71 begin
72 if The_Plaque.Serial_Number = 0 then
73 Counter := Counter +1;
74 The_Plaque.Serial_Number := Counter;
75 else
76 raise Reserialized;
77 end if;
78 end Create;
79
80 function "="( Left_Plaque,Right_Plaque : Object ) return Boolean is
81 begin
82 return (Left_Plaque.Serial_Number = Right_Plaque.Serial_Number)
83 and then -- two uninitialized plates are unequal
84 (Left_Plaque.Serial_Number /= 0);
85 end "=";
86
87 function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
88 return Boolean is
89 begin
90 return (Left_Plaque.Serial_Number = Right_Natural);
91 end TC_Match;
92
93 function Serial_Number( A_Plaque : Object ) return Natural is
94 begin
95 if A_Plaque.Serial_Number = 0 then
96 raise Unserialized;
97 end if;
98 return A_Plaque.Serial_Number;
99 end Serial_Number;
100 end C391001_1;
101
102 with C391001_1;
103 package C391001_2 is -- package Boards is
104
105 package Plaque renames C391001_1;
106
107 type Modes is (Receiving, Transmitting, Standby);
108 type Link(Mode: Modes := Standby) is record
109 case Mode is
110 when Receiving => TC_R : Integer := 100;
111 when Transmitting => TC_T : Integer := 200;
112 when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA
113 end case;
114 end record;
115
116 type Data_Formats is (S_Band, KU_Band, UHF);
117
118
119 type Transceiver(Band: Data_Formats) is tagged limited record
120 ID : Plaque.Object;
121 The_Link: Link;
122 case Band is
123 when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA
124 when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA
125 when UHF => TC_UHF_Data : Integer := 3;
126 end case;
127 end record;
128 end C391001_2;
129
130 with C391001_1;
131 with C391001_2;
132 package C391001_3 is -- package Modules
133 package Plaque renames C391001_1;
134 package Boards renames C391001_2;
135 use type Boards.Modes;
136 use type Boards.Data_Formats;
137
138 type Command_Formats is ( Set_Compression_Code,
139 Set_Data_Rate,
140 Set_Power_State );
141
142 type Electronics_Module(EBand : Boards.Data_Formats;
143 The_Command_Format: Command_Formats)
144 is new Boards.Transceiver(EBand) with record
145 case The_Command_Format is
146 when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA
147 when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA
148 when Set_Power_State => TC_SPS : Integer := 30; -- TSA
149 end case;
150 end record;
151 end C391001_3;
152
153 with Report;
154 with C391001_1;
155 with C391001_2;
156 with C391001_3;
157 procedure C391001 is
158 package Plaque renames C391001_1;
159 package Boards renames C391001_2;
160 package Modules renames C391001_3;
161 use type Boards.Modes;
162 use type Boards.Data_Formats;
163 use type Modules.Command_Formats;
164
165 type Azimuth is range 0..359;
166
167 type Ground_Antenna(The_Band : Boards.Data_Formats;
168 The_Command_Format: Modules.Command_Formats) is
169 record
170 ID : Plaque.Object;
171 Electronics : Modules.Electronics_Module(The_Band,The_Command_Format);
172 Pointing : Azimuth;
173 end record;
174
175 type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band;
176 The_Command : Modules.Command_Formats
177 := Modules.Set_Power_State)
178 is
179 record
180 ID : Plaque.Object;
181 Electronics : Modules.Electronics_Module(The_Band,The_Command);
182 end record;
183
184 The_Ground_Antenna : Ground_Antenna (Boards.S_Band,
185 Modules.Set_Data_Rate);
186 The_Space_Antenna : Space_Antenna;
187 Space_Station_Antenna : Space_Antenna (Boards.S_Band,
188 Modules.Set_Compression_Code);
189
190
191 procedure Validate( Condition : Boolean; Message: String ) is
192 begin
193 if not Condition then
194 Report.Failed("Failed " & Message );
195 end if;
196 end Validate;
197
198 begin
199 Report.Test("C391001", "Check nested tagged discriminated "
200 & "record structures");
201
202 Plaque.Create( The_Ground_Antenna.ID ); -- 1
203 Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2
204 Plaque.Create( The_Space_Antenna.ID ); -- 3
205 Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4
206 Plaque.Create( Space_Station_Antenna.ID ); -- 5
207 Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6
208
209 The_Ground_Antenna.Pointing := 180;
210 Validate( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA discr 1" );
211 Validate( The_Ground_Antenna.The_Command_Format = Modules.Set_Data_Rate,
212 "TGA discr 2" );
213 Validate( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 1" );
214 Validate( The_Ground_Antenna.Electronics.EBand = Boards.S_Band,
215 "TGA comp 2.discr 1" );
216 Validate( The_Ground_Antenna.Electronics.The_Command_Format
217 = Modules.Set_Data_Rate, "TGA comp 2.discr 2" );
218 Validate( The_Ground_Antenna.Electronics.TC_SDR = 20,
219 "TGA comp 2.1" );
220 Validate( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ),
221 "TGA comp 2.inher.1" );
222 Validate( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Standby,
223 "TGA comp 2.inher.2.discr" );
224 Validate( The_Ground_Antenna.Electronics.The_Link.TC_S = 300,
225 "TGA comp 2.inher.2.1" );
226 Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 1,
227 "TGA comp 2.inher.3" );
228 Validate( The_Ground_Antenna.Pointing = 180, "TGA comp 3" );
229
230 Validate( The_Space_Antenna.The_Band = Boards.KU_Band, "TSA discr 1");
231 Validate( The_Space_Antenna.The_Command = Modules.Set_Power_State,
232 "TSA discr 2");
233 Validate( Plaque.TC_Match(The_Space_Antenna.ID,3),
234 "TSA comp 1");
235 Validate( The_Space_Antenna.Electronics.EBand = Boards.KU_Band,
236 "TSA comp 2.discr 1");
237 Validate( The_Space_Antenna.Electronics.The_Command_Format
238 = Modules.Set_Power_State, "TSA comp 2.discr 2");
239 Validate( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4),
240 "TSA comp 2.inher.1");
241 Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Standby,
242 "TSA comp 2.inher.2.discr");
243 Validate( The_Space_Antenna.Electronics.The_Link.TC_S = 300,
244 "TSA comp 2.inher.2.1");
245 Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2,
246 "TSA comp 2.inher.3");
247 Validate( The_Space_Antenna.Electronics.TC_SPS = 30,
248 "TSA comp 2.1");
249
250 Validate( Space_Station_Antenna.The_Band = Boards.S_Band, "SSA discr 1");
251 Validate( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code,
252 "SSA discr 2");
253 Validate( Plaque.TC_Match(Space_Station_Antenna.ID,5),
254 "SSA comp 1");
255 Validate( Space_Station_Antenna.Electronics.EBand = Boards.S_Band,
256 "SSA comp 2.discr 1");
257 Validate( Space_Station_Antenna.Electronics.The_Command_Format
258 = Modules.Set_Compression_Code, "SSA comp 2.discr 2");
259 Validate( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6),
260 "SSA comp 2.inher.1");
261 Validate( Space_Station_Antenna.Electronics.The_Link.Mode = Boards.Standby,
262 "SSA comp 2.inher.2.discr");
263 Validate( Space_Station_Antenna.Electronics.The_Link.TC_S = 300,
264 "SSA comp 2.inher.2.1");
265 Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 1,
266 "SSA comp 2.inher.3");
267 Validate( Space_Station_Antenna.Electronics.TC_SCC = 10,
268 "SSA comp 2.1");
269
270 The_Ground_Antenna.Electronics.TC_SDR := 1001;
271 The_Ground_Antenna.Electronics.The_Link :=
272 (Boards.Transmitting,2001);
273 The_Ground_Antenna.Electronics.TC_S_Band_Data := 3001;
274 The_Ground_Antenna.Pointing := 41;
275
276 The_Space_Antenna.Electronics.The_Link := (Boards.Receiving,1010);
277 The_Space_Antenna.Electronics.TC_KU_Band_Data := 2020;
278 The_Space_Antenna.Electronics.TC_SPS := 3030;
279
280 Space_Station_Antenna.Electronics.The_Link
281 := The_Space_Antenna.Electronics.The_Link;
282 Space_Station_Antenna.Electronics.The_Link.TC_R := 111;
283 Space_Station_Antenna.Electronics.TC_S_Band_Data := 222;
284 Space_Station_Antenna.Electronics.TC_SCC := 333;
285
286 ----------------------------------------------------------------------
287 begin -- should fail discriminant check
288 The_Ground_Antenna.Electronics.TC_SCC := 909;
289 Report.Failed("Discriminant check, no exception");
290 exception
291 when Constraint_Error => null;
292 when others =>
293 Report.Failed("Discriminant check, wrong exception");
294 end;
295
296 Validate( The_Ground_Antenna.Electronics.TC_SDR = 1001,
297 "assigned value 1");
298 Validate( The_Ground_Antenna.Electronics.The_Link.Mode
299 = Boards.Transmitting,
300 "assigned value 2.1");
301 Validate( The_Ground_Antenna.Electronics.The_Link.TC_T = 2001,
302 "assigned value 2.2");
303 Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 3001,
304 "assigned value 3");
305 Validate( The_Ground_Antenna.Pointing = 41,
306 "assigned value 4");
307
308 Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Receiving,
309 "assigned value 5.1");
310 Validate( The_Space_Antenna.Electronics.The_Link.TC_R = 1010,
311 "assigned value 5.2");
312 Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2020,
313 "assigned value 6");
314 Validate( The_Space_Antenna.Electronics.TC_SPS = 3030,
315 "assigned value 7");
316
317 Validate( Space_Station_Antenna.Electronics.The_Link.Mode
318 = Boards.Receiving,
319 "assigned value 8.1");
320 Validate( Space_Station_Antenna.Electronics.The_Link.TC_R = 111,
321 "assigned value 8.2");
322 Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 222,
323 "assigned value 9");
324 Validate( Space_Station_Antenna.Electronics.TC_SCC = 333,
325 "assigned value 10");
326
327 Report.Result;
328
329 end C391001;