Subversion Repositories openrisc

-- C390011.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 tagged types declared within generic package declarations

--     generate distinct tags for each instance of the generic.

--

-- TEST DESCRIPTION:

--     This test defines a very simple generic package (with the expectation

--     that it should be easily be shared), and a few instances of that

--     package.  In true user-like fashion, two of the instances are identical

--     (to wit: IIO is new Integer_IO(Integer)).  The tags generated for each

--     of them are placed into a list.  The last action of the test is to

--     check that everything in the list is unique.

--

--     Almost as an aside, this test defines functions that return T'Base and

--     T'Class, and then exercises these functions.

--

--     (JPR) persistent objects really need a function like:

--        function Get_Object return T'class;

--

--

-- CHANGE HISTORY:

--      20 OCT 95   SAIC   Initial version

--      23 APR 96   SAIC   Commentary Corrections 2.1

--

--!

----------------------------------------------------------------- C390011_0

with Ada.Tags;

package C390011_0 is

  procedure Add_Tag_To_List( T : Ada.Tags.Tag; X_Name, X_Tag: String );

  procedure Check_List_For_Duplicates;

end C390011_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;

package body C390011_0 is

  use type Ada.Tags.Tag;

  type SP is access String;

  type List_Item;

  type List_P is access List_Item;

  type List_Item is record

    The_Tag  : Ada.Tags.Tag;

    Exp_Name : SP;

    Ext_Tag  : SP;

    Next : List_P;

  end record;

  The_List : List_P;

  procedure Add_Tag_To_List ( T : Ada.Tags.Tag; X_Name, X_Tag: String ) is

  begin  -- prepend the tag information to the list

    The_List := new List_Item'( The_Tag  => T,

                                Exp_Name => new String'(X_Name),

                                Ext_Tag  => new String'(X_Tag),

                                Next     => The_List );

  end Add_Tag_To_List;

  procedure Check_List_For_Duplicates is

    Finger : List_P;

    Thumb  : List_P := The_List;

  begin  --

    while Thumb /= null loop

      Finger := Thumb.Next;

      while Finger /= null loop

        -- Check that the tag is unique

        if Finger.The_Tag = Thumb.The_Tag then

          Report.Failed("Duplicate Tag");

        end if;

        -- Check that the Expanded name is unique

        if Finger.Exp_Name.all = Thumb.Exp_Name.all then

          Report.Failed("Tag name " & Finger.Exp_Name.all & " repeats");

        end if;

        -- Check that the External Tag is unique

        if Finger.Ext_Tag.all = Thumb.Ext_Tag.all then

          Report.Failed("External Tag " & Finger.Ext_Tag.all & " repeats");

        end if;

        Finger := Finger.Next;

      end loop;

      Thumb  := Thumb.Next;

   end loop;

  end Check_List_For_Duplicates;

begin

  -- some things I just don't trust...

  if The_List /= null then

    Report.Failed("Implicit default for The_List not null");

  end if;

end C390011_0;

----------------------------------------------------------------- C390011_1

generic

  type Index is (<>);

  type Item is private;

package C390011_1 is

  type List is array(Index range <>) of Item;

  type ListP is access all List;

  type Table is tagged record

    Data: ListP;

  end record;

  function Sort( T: in Table'Class ) return Table'Class;

  function Stable_Table return Table'Class;

  function Table_End( T: Table ) return Index'Base;

end C390011_1;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C390011_1 is

    -- In a user program this package would DO something

  function Sort( T: in Table'Class ) return Table'Class is

  begin

   return T;

  end Sort;

  Empty : Table'Class := Table'( Data => null );

  function Stable_Table return Table'Class is

  begin

    return Empty;

  end Stable_Table;

  function Table_End( T: Table ) return Index'Base is

  begin

    return Index'Base( T.Data.all'Last );

  end Table_End;

end C390011_1;

----------------------------------------------------------------- C390011_2

with C390011_1;

package C390011_2 is new C390011_1( Index => Character, Item => Float );

----------------------------------------------------------------- C390011_3

with C390011_1;

package C390011_3 is new C390011_1( Index => Character, Item => Float );

----------------------------------------------------------------- C390011_4

with C390011_1;

package C390011_4 is new C390011_1( Index => Integer, Item => Character );

----------------------------------------------------------------- C390011_5

with C390011_3;

with C390011_4;

package C390011_5 is

  type Table_3 is new C390011_3.Table with record

    Serial_Number : Integer;

  end record;

  type Table_4 is new C390011_4.Table with record

    Serial_Number : Integer;

  end record;

end C390011_5;

-- no package body C390011_5 required

------------------------------------------------------------------- C390011

with Report;

with C390011_0;

with C390011_2;

with C390011_3;

with C390011_4;

with C390011_5;

with Ada.Tags;

procedure C390011 is

begin  -- Main test procedure.

  Report.Test ("C390011", "Check that tagged types declared within " &

                          "generic package declarations generate distinct " &

                          "tags for each instance of the generic. " &

                          "Check that 'Base may be used as a subtype mark. " &

                          "Check that T'Base and T'Class are allowed as " &

                          "the subtype mark in a function result" );

  -- build the tag information table

  C390011_0.Add_Tag_To_List(T => C390011_2.Table'Tag,

                       X_Name => Ada.Tags.Expanded_Name(C390011_2.Table'Tag),

                       X_Tag  => Ada.Tags.External_Tag(C390011_2.Table'Tag) );

  C390011_0.Add_Tag_To_List(T => C390011_3.Table'Tag,

                       X_Name => Ada.Tags.Expanded_Name(C390011_3.Table'Tag),

                       X_Tag  => Ada.Tags.External_Tag(C390011_3.Table'Tag) );

  C390011_0.Add_Tag_To_List(T => C390011_4.Table'Tag,

                       X_Name => Ada.Tags.Expanded_Name(C390011_4.Table'Tag),

                       X_Tag  => Ada.Tags.External_Tag(C390011_4.Table'Tag) );

  C390011_0.Add_Tag_To_List(T => C390011_5.Table_3'Tag,

                     X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_3'Tag),

                     X_Tag  => Ada.Tags.External_Tag(C390011_5.Table_3'Tag) );

  C390011_0.Add_Tag_To_List(T => C390011_5.Table_4'Tag,

                     X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_4'Tag),

                     X_Tag  => Ada.Tags.External_Tag(C390011_5.Table_4'Tag) );

  -- preform the check for distinct tags

  C390011_0.Check_List_For_Duplicates;

  Report.Result;

end C390011;