Subversion Repositories openrisc

-- 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;