OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c431001.a] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- 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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.