URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c760012.a] - Rev 816
Compare with Previous | Blame | View Log
-- C760012.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 record components that have per-object access discriminant
-- constraints are initialized in the order of their component
-- declarations, and after any components that are not so constrained.
--
-- Check that record components that have per-object access discriminant
-- constraints are finalized in the reverse order of their component
-- declarations, and before any components that are not so constrained.
--
-- TEST DESCRIPTION:
-- The type List_Item is the "container" type. It holds two fields that
-- have per-object access discriminant constraints, and two fields that
-- are not discriminated. These four fields are all controlled types.
-- A fifth field is a pointer used to maintain a linked list of these
-- data objects. Each component is of a unique type which allows for
-- the test to simply track the order of initialization and finalization.
--
-- The types and their purpose are:
-- Constrained_First - a controlled discriminated type
-- Constrained_Second - a controlled discriminated type
-- Simple_First - a controlled type with no discriminant
-- Simple_Second - a controlled type with no discriminant
--
-- The required order of operations:
-- Initialize
-- ( Simple_First | Simple_Second ) -- no "internal order" required
-- Constrained_First
-- Constrained_Second
-- Finalize
-- Constrained_Second
-- Constrained_First
-- ( Simple_First | Simple_Second ) -- must be inverse of init.
--
--
-- CHANGE HISTORY:
-- 23 MAY 95 SAIC Initial version
-- 02 MAY 96 SAIC Reorganized for 2.1
-- 05 DEC 96 SAIC Simplified for 2.1; added init/fin ordering check
-- 31 DEC 97 EDS Remove references to and uses of
-- Initialization_Sequence
--!
---------------------------------------------------------------- C760012_0
with Ada.Finalization;
with Ada.Unchecked_Deallocation;
package C760012_0 is
type List_Item;
type List is access all List_Item;
package Firsts is -- distinguish first from second
type Constrained_First(Container : access List_Item) is
new Ada.Finalization.Limited_Controlled with null record;
procedure Initialize( T : in out Constrained_First );
procedure Finalize ( T : in out Constrained_First );
type Simple_First is new Ada.Finalization.Controlled with
record
My_Init_Seq_Number : Natural;
end record;
procedure Initialize( T : in out Simple_First );
procedure Finalize ( T : in out Simple_First );
end Firsts;
type Constrained_Second(Container : access List_Item) is
new Ada.Finalization.Limited_Controlled with null record;
procedure Initialize( T : in out Constrained_Second );
procedure Finalize ( T : in out Constrained_Second );
type Simple_Second is new Ada.Finalization.Controlled with
record
My_Init_Seq_Number : Natural;
end record;
procedure Initialize( T : in out Simple_Second );
procedure Finalize ( T : in out Simple_Second );
-- by 3.8(18);6.0 the following type contains components constrained
-- by per-object expressions
type List_Item is new Ada.Finalization.Limited_Controlled
with record
ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S
SimpleA : Firsts.Simple_First; -- A T
SimpleB : Simple_Second; -- A T
ContentB : Constrained_Second( List_Item'Access ); -- D R
Next : List; -- | |
end record; -- | |
procedure Initialize( L : in out List_Item ); ------------------+ |
procedure Finalize ( L : in out List_Item ); --------------------+
-- the tags are the same for SimpleA and SimpleB due to the fact that
-- the language does not specify an ordering with respect to this
-- component pair. 7.6(12) does specify the rest of the ordering.
procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List);
end C760012_0;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
with TCTouch;
package body C760012_0 is
package body Firsts is
procedure Initialize( T : in out Constrained_First ) is
begin
TCTouch.Touch('C'); ----------------------------------------------- C
end Initialize;
procedure Finalize ( T : in out Constrained_First ) is
begin
TCTouch.Touch('S'); ----------------------------------------------- S
end Finalize;
procedure Initialize( T : in out Simple_First ) is
begin
T.My_Init_Seq_Number := 0;
TCTouch.Touch('A'); ----------------------------------------------- A
end Initialize;
procedure Finalize ( T : in out Simple_First ) is
begin
TCTouch.Touch('T'); ----------------------------------------------- T
end Finalize;
end Firsts;
procedure Initialize( T : in out Constrained_Second ) is
begin
TCTouch.Touch('D'); ------------------------------------------------- D
end Initialize;
procedure Finalize ( T : in out Constrained_Second ) is
begin
TCTouch.Touch('R'); ------------------------------------------------- R
end Finalize;
procedure Initialize( T : in out Simple_Second ) is
begin
T.My_Init_Seq_Number := 0;
TCTouch.Touch('A'); ------------------------------------------------- A
end Initialize;
procedure Finalize ( T : in out Simple_Second ) is
begin
TCTouch.Touch('T'); ------------------------------------------------- T
end Finalize;
procedure Initialize( L : in out List_Item ) is
begin
TCTouch.Touch('F'); ------------------------------------------------- F
end Initialize;
procedure Finalize ( L : in out List_Item ) is
begin
TCTouch.Touch('Q'); ------------------------------------------------- Q
end Finalize;
end C760012_0;
--------------------------------------------------------------------- C760012
with Report;
with TCTouch;
with C760012_0;
procedure C760012 is
use type C760012_0.List;
procedure Subtest_1 is
-- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints
-- 7.6.1(9);6.0 dictates the order of finalization of the components
One_Of_Them : C760012_0.List_Item;
begin
if One_Of_Them.Next /= null then -- just to hold the subtest in place
Report.Failed("No default value for Next");
end if;
end Subtest_1;
List : C760012_0.List;
procedure Subtest_2 is
begin
List := new C760012_0.List_Item;
List.Next := new C760012_0.List_Item;
end Subtest_2;
procedure Subtest_3 is
begin
C760012_0.Deallocate( List.Next );
C760012_0.Deallocate( List );
end Subtest_3;
begin -- Main test procedure.
Report.Test ("C760012", "Check that record components that have " &
"per-object access discriminant constraints " &
"are initialized in the order of their " &
"component declarations, and after any " &
"components that are not so constrained. " &
"Check that record components that have " &
"per-object access discriminant constraints " &
"are finalized in the reverse order of their " &
"component declarations, and before any " &
"components that are not so constrained" );
Subtest_1;
TCTouch.Validate("AACDFQRSTT", "One object");
Subtest_2;
TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated");
Subtest_3;
TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated");
Report.Result;
end C760012;