URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c390011.a] - Rev 294
Go to most recent revision | Compare with Previous | Blame | View Log
-- 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;
Go to most recent revision | Compare with Previous | Blame | View Log