diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c431001.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c431001.a | 464 |
1 files changed, 464 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c431001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c431001.a new file mode 100644 index 000000000..7d417ce69 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c431001.a @@ -0,0 +1,464 @@ +-- 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; |