Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c4/c431001.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 -- C431001.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 a record aggregate can be given for a nonprivate,
28 -- nonlimited record extension and that the tag of the aggregate
29 -- values are initialized to the tag of the record extension.
30 --
31 -- TEST DESCRIPTION:
32 -- From an initial parent tagged type, several type extensions
33 -- are declared. Each type extension adds components onto
34 -- the existing record structure.
35 --
36 -- In the main procedure, aggregates are declared in two ways.
37 -- In the declarative part, aggregates are used to supply
38 -- initial values for objects of specific types. In the executable
39 -- part, aggregates are used directly as actual parameters to
40 -- a class-wide formal parameter.
41 --
42 -- The abstraction is for a catalog of recordings. A recording
43 -- can be a CD or a record (vinyl). Additionally, a CD may also
44 -- be a CD-ROM, containing both music and data. This type is declared
45 -- as an extension to a type extension, to test that the inclusion
46 -- of record components is transitive across multiple extensions.
47 --
48 -- That the aggregate has the correct tag is verify by feeding
49 -- it to a dispatching operation and confirming that the
50 -- expected subprogram is called as a result. To accomplish this,
51 -- an enumeration type is declared with an enumeration literal
52 -- representing each of the declared types in the hierarchy. A value
53 -- of this type is passed as a parameter to the dispatching
54 -- operation which passes it along to the dispatched subprogram.
55 -- Each dispatched subprogram verifies that it received the
56 -- expected enumeration literal.
57 --
58 -- Not quite fitting the above abstraction are several test cases
59 -- for null records. These tests verify that the new syntax for
60 -- null record aggregates, (null record), is supported. A type is
61 -- declared which extends a null tagged type and adds components.
62 -- Aggregates of this type should include associations for the
63 -- components of the type extension only. Finally, a type is
64 -- declared that adds a null type extension onto a non-null tagged
65 -- type. The aggregate associations should remain the same.
66 --
67 --
68 -- CHANGE HISTORY:
69 -- 06 Dec 94 SAIC ACVC 2.0
70 -- 19 Dec 94 SAIC Removed RM references from objective text.
71 --
72 --!
73 --
74 package C431001_0 is
75
76 -- Values of TC_Type_ID are passed through to dispatched subprogram
77 -- calls so that it can be verified that the dispatching resulted in
78 -- the expected call.
79 type TC_Type_ID is (TC_Recording, TC_CD, TC_Vinyl, TC_CD_ROM);
80
81 type Genre is (Classical, Country, Jazz, Rap, Rock, World);
82
83 type Recording is tagged record
84 Artist : String (1..20);
85 Category : Genre;
86 Length : Duration;
87 Selections : Positive;
88 end record;
89
90 function Summary (R : in Recording;
91 TC_Type : in TC_Type_ID) return String;
92
93 type Recording_Method is (Audio, Digital);
94 type CD is new Recording with record
95 Recorded : Recording_Method;
96 Mastered : Recording_Method;
97 end record;
98
99 function Summary (Disc : in CD;
100 TC_Type : in TC_Type_ID) return String;
101
102 type Playing_Speed is (LP_33, Single_45, Old_78);
103 type Vinyl is new Recording with record
104 Speed : Playing_Speed;
105 end record;
106
107 function Summary (Album : in Vinyl;
108 TC_Type : in TC_Type_ID) return String;
109
110
111 type CD_ROM is new CD with record
112 Storage : Positive;
113 end record;
114
115 function Summary (Disk : in CD_ROM;
116 TC_Type : in TC_Type_ID) return String;
117
118 function Catalog_Entry (R : in Recording'Class;
119 TC_Type : in TC_Type_ID) return String;
120
121 procedure Print (S : in String); -- provides somewhere for the
122 -- results of Catalog_Entry to
123 -- "go", so they don't get
124 -- optimized away.
125
126 -- The types and procedures declared below are not a continuation
127 -- of the Recording abstraction. These types are intended to test
128 -- support for null tagged types and type extensions. TC_Check mirrors
129 -- the operation of function Summary, above. Similarly, TC_Dispatch
130 -- mirrors the operation of Catalog_Entry.
131
132 type TC_N_Type_ID is
133 (TC_Null_Tagged, TC_Null_Extension,
134 TC_Extension_Of_Null, TC_Null_Extension_Of_Nonnull);
135
136 type Null_Tagged is tagged null record;
137 procedure TC_Check (N : in Null_Tagged;
138 TC_Type : in TC_N_Type_ID);
139
140 type Null_Extension is new Null_Tagged with null record;
141 procedure TC_Check (N : in Null_Extension;
142 TC_Type : in TC_N_Type_ID);
143
144 type Extension_Of_Null is new Null_Tagged with record
145 New_Component1 : Boolean;
146 New_Component2 : Natural;
147 end record;
148 procedure TC_Check (N : in Extension_Of_Null;
149 TC_Type : in TC_N_Type_ID);
150
151 type Null_Extension_Of_Nonnull is new Extension_Of_Null
152 with null record;
153 procedure TC_Check (N : in Null_Extension_Of_Nonnull;
154 TC_Type : in TC_N_Type_ID);
155
156 procedure TC_Dispatch (N : in Null_Tagged'Class;
157 TC_Type : in TC_N_Type_ID);
158
159 end C431001_0;
160
161 with Report;
162 package body C431001_0 is
163
164 function Summary (R : in Recording;
165 TC_Type : in TC_Type_ID) return String is
166 begin
167
168 if TC_Type /= TC_Recording then
169 Report.Failed ("Did not dispatch on tag for tagged parent " &
170 "type Recording");
171 end if;
172
173 return R.Artist (1..10)
174 & ' ' & Genre'Image (R.Category) (1..2)
175 & ' ' & Duration'Image (R.Length)
176 & ' ' & Integer'Image (R.Selections);
177
178 end Summary;
179
180 function Summary (Disc : in CD;
181 TC_Type : in TC_Type_ID) return String is
182 begin
183
184 if TC_Type /= TC_CD then
185 Report.Failed ("Did not dispatch on tag for type extension " &
186 "CD");
187 end if;
188
189 return Summary (Recording (Disc), TC_Type => TC_Recording)
190 & ' ' & Recording_Method'Image(Disc.Recorded)(1)
191 & Recording_Method'Image(Disc.Mastered)(1);
192
193 end Summary;
194
195 function Summary (Album : in Vinyl;
196 TC_Type : in TC_Type_ID) return String is
197 begin
198 if TC_Type /= TC_Vinyl then
199 Report.Failed ("Did not dispatch on tag for type extension " &
200 "Vinyl");
201 end if;
202
203 case Album.Speed is
204 when LP_33 =>
205 return Summary (Recording (Album), TC_Type => TC_Recording)
206 & " 33";
207 when Single_45 =>
208 return Summary (Recording (Album), TC_Type => TC_Recording)
209 & " 45";
210 when Old_78 =>
211 return Summary (Recording (Album), TC_Type => TC_Recording)
212 & " 78";
213 end case;
214
215 end Summary;
216
217 function Summary (Disk : in CD_ROM;
218 TC_Type : in TC_Type_ID) return String is
219 begin
220 if TC_Type /= TC_CD_ROM then
221 Report.Failed ("Did not dispatch on tag for type extension " &
222 "CD_ROM. This is an extension of the type " &
223 "extension CD");
224 end if;
225
226 return Summary (Recording(Disk), TC_Type => TC_Recording)
227 & ' ' & Integer'Image (Disk.Storage) & 'K';
228
229 end Summary;
230
231 function Catalog_Entry (R : in Recording'Class;
232 TC_Type : in TC_Type_ID) return String is
233 begin
234 return Summary (R, TC_Type); -- dispatched call
235 end Catalog_Entry;
236
237 procedure Print (S : in String) is
238 T : String (1..S'Length) := Report.Ident_Str (S);
239 begin
240 -- Ada.Text_IO.Put_Line (S);
241 null;
242 end Print;
243
244 -- Bodies for null type checks
245 procedure TC_Check (N : in Null_Tagged;
246 TC_Type : in TC_N_Type_ID) is
247 begin
248 if TC_Type /= TC_Null_Tagged then
249 Report.Failed ("Did not dispatch on tag for null tagged " &
250 "type Null_Tagged");
251 end if;
252 end TC_Check;
253
254 procedure TC_Check (N : in Null_Extension;
255 TC_Type : in TC_N_Type_ID) is
256 begin
257 if TC_Type /= TC_Null_Extension then
258 Report.Failed ("Did not dispatch on tag for null tagged " &
259 "type extension Null_Extension");
260 end if;
261 end TC_Check;
262
263 procedure TC_Check (N : in Extension_Of_Null;
264 TC_Type : in TC_N_Type_ID) is
265 begin
266 if TC_Type /= TC_Extension_Of_Null then
267 Report.Failed
268 ("Did not dispatch on tag for extension of null parent" &
269 "type");
270 end if;
271 end TC_Check;
272
273 procedure TC_Check (N : in Null_Extension_Of_Nonnull;
274 TC_Type : in TC_N_Type_ID) is
275 begin
276 if TC_Type /= TC_Null_Extension_Of_Nonnull then
277 Report.Failed
278 ("Did not dispatch on tag for null extension of nonnull " &
279 "parent type");
280 end if;
281 end TC_Check;
282
283 procedure TC_Dispatch (N : in Null_Tagged'Class;
284 TC_Type : in TC_N_Type_ID) is
285 begin
286 TC_Check (N, TC_Type); -- dispatched call
287 end TC_Dispatch;
288
289 end C431001_0;
290
291
292 with C431001_0;
293 with Report;
294 procedure C431001 is
295
296 -- Tagged type
297 -- Named component associations
298 DAT : C431001_0.Recording :=
299 (Artist => "Aerosmith ",
300 Category => C431001_0.Rock,
301 Length => 48.5,
302 Selections => 10);
303
304 -- Type extensions
305 -- Named component associations
306 Disc1 : C431001_0.CD :=
307 (Artist => "London Symphony ",
308 Category => C431001_0.Classical,
309 Length => 55.0,
310 Selections => 4,
311 Recorded => C431001_0.Digital,
312 Mastered => C431001_0.Digital);
313
314 -- Named component associations with others
315 Disc2 : C431001_0.CD :=
316 (Artist => "Pink Floyd ",
317 Category => C431001_0.Rock,
318 Length => 51.8,
319 Selections => 5,
320 others => C431001_0.Audio); -- Recorded
321 -- Mastered
322
323 -- Positional component associations
324 Album1 : C431001_0.Vinyl :=
325 ("Hammer ", -- Artist
326 C431001_0.Rap, -- Category
327 46.2, -- Length
328 9, -- Selections
329 C431001_0.LP_33); -- Speed
330
331 -- Mixed positional and named component associations
332 -- Named component associations out of order
333 Album2 : C431001_0.Vinyl :=
334 ("Balinese Gamelan ", -- Artist
335 C431001_0.World, -- Category
336 42.6, -- Length
337 14, -- Selections
338 C431001_0.LP_33); -- Speed
339
340 -- Type extension, parent is also type extension
341 -- Named notation, components out of order
342 Data : C431001_0.CD_ROM :=
343 (Storage => 140,
344 Mastered => C431001_0.Digital,
345 Category => C431001_0.Rock,
346 Selections => 10,
347 Recorded => C431001_0.Digital,
348 Artist => "Black, Clint ",
349 Length => 48.5);
350
351 -- Null tagged type
352 Null_Rec : C431001_0.Null_Tagged := (null record);
353
354 -- Null type extension
355 Null_Ext : C431001_0.Null_Extension := (null record);
356
357 -- Nonnull extension of null parent
358 Ext_Of_Null : C431001_0.Extension_Of_Null := (True, 0);
359
360 -- Null extension of nonnull parent
361 Null_Ext_Of_Nonnull : C431001_0.Null_Extension_Of_Nonnull
362 := (False, 1);
363
364 begin
365
366 Report.Test ("C431001", "Aggregate values for type extensions");
367
368 C431001_0.Print (C431001_0.Catalog_Entry (DAT, C431001_0.TC_Recording));
369 C431001_0.Print (C431001_0.Catalog_Entry (Disc1, C431001_0.TC_CD));
370 C431001_0.Print (C431001_0.Catalog_Entry (Disc2, C431001_0.TC_CD));
371 C431001_0.Print (C431001_0.Catalog_Entry (Album1, C431001_0.TC_Vinyl));
372 C431001_0.Print (C431001_0.Catalog_Entry (Album2, C431001_0.TC_Vinyl));
373 C431001_0.Print (C431001_0.Catalog_Entry (Data, C431001_0.TC_CD_ROM));
374
375 C431001_0.TC_Dispatch (Null_Rec, C431001_0.TC_Null_Tagged);
376 C431001_0.TC_Dispatch (Null_Ext, C431001_0.TC_Null_Extension);
377 C431001_0.TC_Dispatch (Ext_Of_Null, C431001_0.TC_Extension_Of_Null);
378 C431001_0.TC_Dispatch
379 (Null_Ext_Of_Nonnull, C431001_0.TC_Null_Extension_Of_Nonnull);
380
381 -- Tagged type
382 -- Named component associations
383 C431001_0.Print (C431001_0.Catalog_Entry
384 (TC_Type => C431001_0.TC_Recording,
385 R => C431001_0.Recording'(Artist => "Zappa, Frank ",
386 Category => C431001_0.Rock,
387 Length => 70.0,
388 Selections => 38)));
389
390 -- Type extensions
391 -- Named component associations
392 C431001_0.Print (C431001_0.Catalog_Entry
393 (TC_Type => C431001_0.TC_CD,
394 R => C431001_0.CD'(Artist => "Dog, Snoop Doggy ",
395 Category => C431001_0.Rap,
396 Length => 37.3,
397 Selections => 8,
398 Recorded => C431001_0.Audio,
399 Mastered => C431001_0.Digital)));
400
401 -- Named component associations with others
402 C431001_0.Print (C431001_0.Catalog_Entry
403 (TC_Type => C431001_0.TC_CD,
404 R => C431001_0.CD'(Artist => "Judd, Winona ",
405 Category => C431001_0.Country,
406 Length => 51.2,
407 Selections => 11,
408 others => C431001_0.Digital))); -- Recorded
409 -- Mastered
410
411 -- Positional component associations
412 C431001_0.Print (C431001_0.Catalog_Entry
413 (TC_Type => C431001_0.TC_Vinyl,
414 R => C431001_0.Vinyl'("Davis, Miles ", -- Artist
415 C431001_0.Jazz, -- Category
416 50.4, -- Length
417 10, -- Selections
418 C431001_0.LP_33))); -- Speed
419
420 -- Mixed positional and named component associations
421 -- Named component associations out of order
422 C431001_0.Print (C431001_0.Catalog_Entry
423 (TC_Type => C431001_0.TC_Vinyl,
424 R => C431001_0.Vinyl'("Zamfir ", -- Artist
425 C431001_0.World, -- Category
426 Speed => C431001_0.LP_33,
427 Selections => 14,
428 Length => 56.5)));
429
430 -- Type extension, parent is also type extension
431 -- Named notation, components out of order
432 C431001_0.Print (C431001_0.Catalog_Entry
433 (TC_Type => C431001_0.TC_CD_ROM,
434 R => C431001_0.CD_ROM'(Storage => 720,
435 Category => C431001_0.Classical,
436 Recorded => C431001_0.Digital,
437 Artist => "Baltimore Symphony ",
438 Length => 68.9,
439 Mastered => C431001_0.Digital,
440 Selections => 5)));
441
442 -- Null tagged type
443 C431001_0.TC_Dispatch
444 (TC_Type => C431001_0.TC_Null_Tagged,
445 N => C431001_0.Null_Tagged'(null record));
446
447 -- Null type extension
448 C431001_0.TC_Dispatch
449 (TC_Type => C431001_0.TC_Null_Extension,
450 N => C431001_0.Null_Extension'(null record));
451
452 -- Nonnull extension of null parent
453 C431001_0.TC_Dispatch
454 (TC_Type => C431001_0.TC_Extension_Of_Null,
455 N => C431001_0.Extension_Of_Null'(True, 3));
456
457 -- Null extension of nonnull parent
458 C431001_0.TC_Dispatch
459 (TC_Type => C431001_0.TC_Extension_Of_Null,
460 N => C431001_0.Extension_Of_Null'(False, 4));
461
462 Report.Result;
463
464 end C431001;