| -- C431001.A |
| -- |
| -- Grant of Unlimited Rights |
| -- |
| -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, |
| -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained |
| -- unlimited rights in the software and documentation contained herein. |
| -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making |
| -- this public release, the Government intends to confer upon all |
| -- recipients unlimited rights equal to those held by the Government. |
| -- These rights include rights to use, duplicate, release or disclose the |
| -- released technical data and computer software in whole or in part, in |
| -- any manner and for any purpose whatsoever, and to have or permit others |
| -- to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- |
| -- OBJECTIVE: |
| -- Check that a record aggregate can be given for a nonprivate, |
| -- nonlimited record extension and that the tag of the aggregate |
| -- values are initialized to the tag of the record extension. |
| -- |
| -- TEST DESCRIPTION: |
| -- From an initial parent tagged type, several type extensions |
| -- are declared. Each type extension adds components onto |
| -- the existing record structure. |
| -- |
| -- In the main procedure, aggregates are declared in two ways. |
| -- In the declarative part, aggregates are used to supply |
| -- initial values for objects of specific types. In the executable |
| -- part, aggregates are used directly as actual parameters to |
| -- a class-wide formal parameter. |
| -- |
| -- The abstraction is for a catalog of recordings. A recording |
| -- can be a CD or a record (vinyl). Additionally, a CD may also |
| -- be a CD-ROM, containing both music and data. This type is declared |
| -- as an extension to a type extension, to test that the inclusion |
| -- of record components is transitive across multiple extensions. |
| -- |
| -- That the aggregate has the correct tag is verify by feeding |
| -- it to a dispatching operation and confirming that the |
| -- expected subprogram is called as a result. To accomplish this, |
| -- an enumeration type is declared with an enumeration literal |
| -- representing each of the declared types in the hierarchy. A value |
| -- of this type is passed as a parameter to the dispatching |
| -- operation which passes it along to the dispatched subprogram. |
| -- Each dispatched subprogram verifies that it received the |
| -- expected enumeration literal. |
| -- |
| -- Not quite fitting the above abstraction are several test cases |
| -- for null records. These tests verify that the new syntax for |
| -- null record aggregates, (null record), is supported. A type is |
| -- declared which extends a null tagged type and adds components. |
| -- Aggregates of this type should include associations for the |
| -- components of the type extension only. Finally, a type is |
| -- declared that adds a null type extension onto a non-null tagged |
| -- type. The aggregate associations should remain the same. |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- 19 Dec 94 SAIC Removed RM references from objective text. |
| -- |
| --! |
| -- |
| package C431001_0 is |
| |
| -- Values of TC_Type_ID are passed through to dispatched subprogram |
| -- calls so that it can be verified that the dispatching resulted in |
| -- the expected call. |
| type TC_Type_ID is (TC_Recording, TC_CD, TC_Vinyl, TC_CD_ROM); |
| |
| type Genre is (Classical, Country, Jazz, Rap, Rock, World); |
| |
| type Recording is tagged record |
| Artist : String (1..20); |
| Category : Genre; |
| Length : Duration; |
| Selections : Positive; |
| end record; |
| |
| function Summary (R : in Recording; |
| TC_Type : in TC_Type_ID) return String; |
| |
| type Recording_Method is (Audio, Digital); |
| type CD is new Recording with record |
| Recorded : Recording_Method; |
| Mastered : Recording_Method; |
| end record; |
| |
| function Summary (Disc : in CD; |
| TC_Type : in TC_Type_ID) return String; |
| |
| type Playing_Speed is (LP_33, Single_45, Old_78); |
| type Vinyl is new Recording with record |
| Speed : Playing_Speed; |
| end record; |
| |
| function Summary (Album : in Vinyl; |
| TC_Type : in TC_Type_ID) return String; |
| |
| |
| type CD_ROM is new CD with record |
| Storage : Positive; |
| end record; |
| |
| function Summary (Disk : in CD_ROM; |
| TC_Type : in TC_Type_ID) return String; |
| |
| function Catalog_Entry (R : in Recording'Class; |
| TC_Type : in TC_Type_ID) return String; |
| |
| procedure Print (S : in String); -- provides somewhere for the |
| -- results of Catalog_Entry to |
| -- "go", so they don't get |
| -- optimized away. |
| |
| -- The types and procedures declared below are not a continuation |
| -- of the Recording abstraction. These types are intended to test |
| -- support for null tagged types and type extensions. TC_Check mirrors |
| -- the operation of function Summary, above. Similarly, TC_Dispatch |
| -- mirrors the operation of Catalog_Entry. |
| |
| type TC_N_Type_ID is |
| (TC_Null_Tagged, TC_Null_Extension, |
| TC_Extension_Of_Null, TC_Null_Extension_Of_Nonnull); |
| |
| type Null_Tagged is tagged null record; |
| procedure TC_Check (N : in Null_Tagged; |
| TC_Type : in TC_N_Type_ID); |
| |
| type Null_Extension is new Null_Tagged with null record; |
| procedure TC_Check (N : in Null_Extension; |
| TC_Type : in TC_N_Type_ID); |
| |
| type Extension_Of_Null is new Null_Tagged with record |
| New_Component1 : Boolean; |
| New_Component2 : Natural; |
| end record; |
| procedure TC_Check (N : in Extension_Of_Null; |
| TC_Type : in TC_N_Type_ID); |
| |
| type Null_Extension_Of_Nonnull is new Extension_Of_Null |
| with null record; |
| procedure TC_Check (N : in Null_Extension_Of_Nonnull; |
| TC_Type : in TC_N_Type_ID); |
| |
| procedure TC_Dispatch (N : in Null_Tagged'Class; |
| TC_Type : in TC_N_Type_ID); |
| |
| end C431001_0; |
| |
| with Report; |
| package body C431001_0 is |
| |
| function Summary (R : in Recording; |
| TC_Type : in TC_Type_ID) return String is |
| begin |
| |
| if TC_Type /= TC_Recording then |
| Report.Failed ("Did not dispatch on tag for tagged parent " & |
| "type Recording"); |
| end if; |
| |
| return R.Artist (1..10) |
| & ' ' & Genre'Image (R.Category) (1..2) |
| & ' ' & Duration'Image (R.Length) |
| & ' ' & Integer'Image (R.Selections); |
| |
| end Summary; |
| |
| function Summary (Disc : in CD; |
| TC_Type : in TC_Type_ID) return String is |
| begin |
| |
| if TC_Type /= TC_CD then |
| Report.Failed ("Did not dispatch on tag for type extension " & |
| "CD"); |
| end if; |
| |
| return Summary (Recording (Disc), TC_Type => TC_Recording) |
| & ' ' & Recording_Method'Image(Disc.Recorded)(1) |
| & Recording_Method'Image(Disc.Mastered)(1); |
| |
| end Summary; |
| |
| function Summary (Album : in Vinyl; |
| TC_Type : in TC_Type_ID) return String is |
| begin |
| if TC_Type /= TC_Vinyl then |
| Report.Failed ("Did not dispatch on tag for type extension " & |
| "Vinyl"); |
| end if; |
| |
| case Album.Speed is |
| when LP_33 => |
| return Summary (Recording (Album), TC_Type => TC_Recording) |
| & " 33"; |
| when Single_45 => |
| return Summary (Recording (Album), TC_Type => TC_Recording) |
| & " 45"; |
| when Old_78 => |
| return Summary (Recording (Album), TC_Type => TC_Recording) |
| & " 78"; |
| end case; |
| |
| end Summary; |
| |
| function Summary (Disk : in CD_ROM; |
| TC_Type : in TC_Type_ID) return String is |
| begin |
| if TC_Type /= TC_CD_ROM then |
| Report.Failed ("Did not dispatch on tag for type extension " & |
| "CD_ROM. This is an extension of the type " & |
| "extension CD"); |
| end if; |
| |
| return Summary (Recording(Disk), TC_Type => TC_Recording) |
| & ' ' & Integer'Image (Disk.Storage) & 'K'; |
| |
| end Summary; |
| |
| function Catalog_Entry (R : in Recording'Class; |
| TC_Type : in TC_Type_ID) return String is |
| begin |
| return Summary (R, TC_Type); -- dispatched call |
| end Catalog_Entry; |
| |
| procedure Print (S : in String) is |
| T : String (1..S'Length) := Report.Ident_Str (S); |
| begin |
| -- Ada.Text_IO.Put_Line (S); |
| null; |
| end Print; |
| |
| -- Bodies for null type checks |
| procedure TC_Check (N : in Null_Tagged; |
| TC_Type : in TC_N_Type_ID) is |
| begin |
| if TC_Type /= TC_Null_Tagged then |
| Report.Failed ("Did not dispatch on tag for null tagged " & |
| "type Null_Tagged"); |
| end if; |
| end TC_Check; |
| |
| procedure TC_Check (N : in Null_Extension; |
| TC_Type : in TC_N_Type_ID) is |
| begin |
| if TC_Type /= TC_Null_Extension then |
| Report.Failed ("Did not dispatch on tag for null tagged " & |
| "type extension Null_Extension"); |
| end if; |
| end TC_Check; |
| |
| procedure TC_Check (N : in Extension_Of_Null; |
| TC_Type : in TC_N_Type_ID) is |
| begin |
| if TC_Type /= TC_Extension_Of_Null then |
| Report.Failed |
| ("Did not dispatch on tag for extension of null parent" & |
| "type"); |
| end if; |
| end TC_Check; |
| |
| procedure TC_Check (N : in Null_Extension_Of_Nonnull; |
| TC_Type : in TC_N_Type_ID) is |
| begin |
| if TC_Type /= TC_Null_Extension_Of_Nonnull then |
| Report.Failed |
| ("Did not dispatch on tag for null extension of nonnull " & |
| "parent type"); |
| end if; |
| end TC_Check; |
| |
| procedure TC_Dispatch (N : in Null_Tagged'Class; |
| TC_Type : in TC_N_Type_ID) is |
| begin |
| TC_Check (N, TC_Type); -- dispatched call |
| end TC_Dispatch; |
| |
| end C431001_0; |
| |
| |
| with C431001_0; |
| with Report; |
| procedure C431001 is |
| |
| -- Tagged type |
| -- Named component associations |
| DAT : C431001_0.Recording := |
| (Artist => "Aerosmith ", |
| Category => C431001_0.Rock, |
| Length => 48.5, |
| Selections => 10); |
| |
| -- Type extensions |
| -- Named component associations |
| Disc1 : C431001_0.CD := |
| (Artist => "London Symphony ", |
| Category => C431001_0.Classical, |
| Length => 55.0, |
| Selections => 4, |
| Recorded => C431001_0.Digital, |
| Mastered => C431001_0.Digital); |
| |
| -- Named component associations with others |
| Disc2 : C431001_0.CD := |
| (Artist => "Pink Floyd ", |
| Category => C431001_0.Rock, |
| Length => 51.8, |
| Selections => 5, |
| others => C431001_0.Audio); -- Recorded |
| -- Mastered |
| |
| -- Positional component associations |
| Album1 : C431001_0.Vinyl := |
| ("Hammer ", -- Artist |
| C431001_0.Rap, -- Category |
| 46.2, -- Length |
| 9, -- Selections |
| C431001_0.LP_33); -- Speed |
| |
| -- Mixed positional and named component associations |
| -- Named component associations out of order |
| Album2 : C431001_0.Vinyl := |
| ("Balinese Gamelan ", -- Artist |
| C431001_0.World, -- Category |
| 42.6, -- Length |
| 14, -- Selections |
| C431001_0.LP_33); -- Speed |
| |
| -- Type extension, parent is also type extension |
| -- Named notation, components out of order |
| Data : C431001_0.CD_ROM := |
| (Storage => 140, |
| Mastered => C431001_0.Digital, |
| Category => C431001_0.Rock, |
| Selections => 10, |
| Recorded => C431001_0.Digital, |
| Artist => "Black, Clint ", |
| Length => 48.5); |
| |
| -- Null tagged type |
| Null_Rec : C431001_0.Null_Tagged := (null record); |
| |
| -- Null type extension |
| Null_Ext : C431001_0.Null_Extension := (null record); |
| |
| -- Nonnull extension of null parent |
| Ext_Of_Null : C431001_0.Extension_Of_Null := (True, 0); |
| |
| -- Null extension of nonnull parent |
| Null_Ext_Of_Nonnull : C431001_0.Null_Extension_Of_Nonnull |
| := (False, 1); |
| |
| begin |
| |
| Report.Test ("C431001", "Aggregate values for type extensions"); |
| |
| C431001_0.Print (C431001_0.Catalog_Entry (DAT, C431001_0.TC_Recording)); |
| C431001_0.Print (C431001_0.Catalog_Entry (Disc1, C431001_0.TC_CD)); |
| C431001_0.Print (C431001_0.Catalog_Entry (Disc2, C431001_0.TC_CD)); |
| C431001_0.Print (C431001_0.Catalog_Entry (Album1, C431001_0.TC_Vinyl)); |
| C431001_0.Print (C431001_0.Catalog_Entry (Album2, C431001_0.TC_Vinyl)); |
| C431001_0.Print (C431001_0.Catalog_Entry (Data, C431001_0.TC_CD_ROM)); |
| |
| C431001_0.TC_Dispatch (Null_Rec, C431001_0.TC_Null_Tagged); |
| C431001_0.TC_Dispatch (Null_Ext, C431001_0.TC_Null_Extension); |
| C431001_0.TC_Dispatch (Ext_Of_Null, C431001_0.TC_Extension_Of_Null); |
| C431001_0.TC_Dispatch |
| (Null_Ext_Of_Nonnull, C431001_0.TC_Null_Extension_Of_Nonnull); |
| |
| -- Tagged type |
| -- Named component associations |
| C431001_0.Print (C431001_0.Catalog_Entry |
| (TC_Type => C431001_0.TC_Recording, |
| R => C431001_0.Recording'(Artist => "Zappa, Frank ", |
| Category => C431001_0.Rock, |
| Length => 70.0, |
| Selections => 38))); |
| |
| -- Type extensions |
| -- Named component associations |
| C431001_0.Print (C431001_0.Catalog_Entry |
| (TC_Type => C431001_0.TC_CD, |
| R => C431001_0.CD'(Artist => "Dog, Snoop Doggy ", |
| Category => C431001_0.Rap, |
| Length => 37.3, |
| Selections => 8, |
| Recorded => C431001_0.Audio, |
| Mastered => C431001_0.Digital))); |
| |
| -- Named component associations with others |
| C431001_0.Print (C431001_0.Catalog_Entry |
| (TC_Type => C431001_0.TC_CD, |
| R => C431001_0.CD'(Artist => "Judd, Winona ", |
| Category => C431001_0.Country, |
| Length => 51.2, |
| Selections => 11, |
| others => C431001_0.Digital))); -- Recorded |
| -- Mastered |
| |
| -- Positional component associations |
| C431001_0.Print (C431001_0.Catalog_Entry |
| (TC_Type => C431001_0.TC_Vinyl, |
| R => C431001_0.Vinyl'("Davis, Miles ", -- Artist |
| C431001_0.Jazz, -- Category |
| 50.4, -- Length |
| 10, -- Selections |
| C431001_0.LP_33))); -- Speed |
| |
| -- Mixed positional and named component associations |
| -- Named component associations out of order |
| C431001_0.Print (C431001_0.Catalog_Entry |
| (TC_Type => C431001_0.TC_Vinyl, |
| R => C431001_0.Vinyl'("Zamfir ", -- Artist |
| C431001_0.World, -- Category |
| Speed => C431001_0.LP_33, |
| Selections => 14, |
| Length => 56.5))); |
| |
| -- Type extension, parent is also type extension |
| -- Named notation, components out of order |
| C431001_0.Print (C431001_0.Catalog_Entry |
| (TC_Type => C431001_0.TC_CD_ROM, |
| R => C431001_0.CD_ROM'(Storage => 720, |
| Category => C431001_0.Classical, |
| Recorded => C431001_0.Digital, |
| Artist => "Baltimore Symphony ", |
| Length => 68.9, |
| Mastered => C431001_0.Digital, |
| Selections => 5))); |
| |
| -- Null tagged type |
| C431001_0.TC_Dispatch |
| (TC_Type => C431001_0.TC_Null_Tagged, |
| N => C431001_0.Null_Tagged'(null record)); |
| |
| -- Null type extension |
| C431001_0.TC_Dispatch |
| (TC_Type => C431001_0.TC_Null_Extension, |
| N => C431001_0.Null_Extension'(null record)); |
| |
| -- Nonnull extension of null parent |
| C431001_0.TC_Dispatch |
| (TC_Type => C431001_0.TC_Extension_Of_Null, |
| N => C431001_0.Extension_Of_Null'(True, 3)); |
| |
| -- Null extension of nonnull parent |
| C431001_0.TC_Dispatch |
| (TC_Type => C431001_0.TC_Extension_Of_Null, |
| N => C431001_0.Extension_Of_Null'(False, 4)); |
| |
| Report.Result; |
| |
| end C431001; |
