c390011.a

来自「用于进行gcc测试」· A 代码 · 共 251 行

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