diff options
author | (no author) <(no author)@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-04-22 18:51:16 +0000 |
---|---|---|
committer | (no author) <(no author)@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-04-22 18:51:16 +0000 |
commit | 3620a217adfbde3c2249b18205d19c13b317f3b0 (patch) | |
tree | 8c306f5f27b8edf1ef6e9ea83e476b9872e5642a /gcc/testsuite/ada/acats/tests/c3/c392011.a | |
parent | 86248a4b2696dd0f45ceabfd239e870ba0d36c89 (diff) |
This commit was manufactured by cvs2svn to create tagapple/gcc-1742
'apple-gcc-1742'.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/tags/apple-gcc-1742@81049 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392011.a')
-rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c392011.a | 299 |
1 files changed, 0 insertions, 299 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392011.a b/gcc/testsuite/ada/acats/tests/c3/c392011.a deleted file mode 100644 index c32ec77c0d0..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392011.a +++ /dev/null @@ -1,299 +0,0 @@ --- C392011.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 if a function call with a controlling result is itself --- a controlling operand of an enclosing call on a dispatching operation, --- then its controlling tag value is determined by the controlling tag --- value of the enclosing call. --- --- TEST DESCRIPTION: --- The test builds and traverses a "ragged" list; a linked list which --- contains data elements of three different types (all rooted at --- Level_0'Class). The traversal of this list checks the objective --- by calling the dispatching operation "Check" using an item from the --- list, and calling the function create; thus causing the controlling --- result of the function to be determined by evaluating the value of --- the other controlling parameter to the two-parameter Check. --- --- --- CHANGE HISTORY: --- 22 SEP 95 SAIC Initial version --- 23 APR 96 SAIC Corrected commentary, differentiated integer. --- ---! - ------------------------------------------------------------------ C392011_0 - -package C392011_0 is - - type Level_0 is tagged record - Ch_Item : Character; - end record; - - function Create return Level_0; - -- primitive dispatching function - - procedure Check( Left, Right: in Level_0 ); - -- has controlling parameters - -end C392011_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -with TCTouch; -package body C392011_0 is - - The_Character : Character := 'A'; - - function Create return Level_0 is - Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character ); - begin - The_Character := Character'Succ(The_Character); - TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A - return Created_Item_0; - end Create; - - procedure Check( Left, Right: in Level_0 ) is - begin - TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B - end Check; - -end C392011_0; - ------------------------------------------------------------------ C392011_1 - -with C392011_0; -package C392011_1 is - - type Level_1 is new C392011_0.Level_0 with record - Int_Item : Integer; - end record; - - -- note that Create becomes abstract upon this derivation hence: - - function Create return Level_1; - - procedure Check( Left, Right: in Level_1 ); - -end C392011_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C392011_1 is - - Integer_1 : Integer := 0; - - function Create return Level_1 is - Created_Item_1 : constant Level_1 - := ( C392011_0.Create with Int_Item => Integer_1 ); - -- note call to ^--------------^ -- A - begin - Integer_1 := Integer'Succ(Integer_1); - TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C - return Created_Item_1; - end Create; - - procedure Check( Left, Right: in Level_1 ) is - begin - TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D - end Check; - -end C392011_1; - ------------------------------------------------------------------ C392011_2 - -with C392011_1; -package C392011_2 is - - type Level_2 is new C392011_1.Level_1 with record - Another_Int_Item : Integer; - end record; - - -- note that Create becomes abstract upon this derivation hence: - - function Create return Level_2; - - procedure Check( Left, Right: in Level_2 ); - -end C392011_2; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C392011_2 is - - Integer_2 : Integer := 100; - - function Create return Level_2 is - Created_Item_2 : constant Level_2 - := ( C392011_1.Create with Another_Int_Item => Integer_2 ); - -- note call to ^--------------^ -- AC - begin - Integer_2 := Integer'Succ(Integer_2); - TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E - return Created_Item_2; - end Create; - - procedure Check( Left, Right: in Level_2 ) is - begin - TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F - end Check; - -end C392011_2; - -------------------------------------------------------- C392011_2.C392011_3 - -with C392011_0; -package C392011_2.C392011_3 is - - type Wide_Reference is access all C392011_0.Level_0'Class; - - type Ragged_Element; - - type List_Pointer is access Ragged_Element; - - type Ragged_Element is record - Data : Wide_Reference; - Next : List_Pointer; - end record; - - procedure Build_List; - - procedure Traverse_List; - -end C392011_2.C392011_3; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -package body C392011_2.C392011_3 is - - The_List : List_Pointer; - - procedure Build_List is - begin - - -- build a list that looks like: - -- Level_2, Level_1, Level_2, Level_1, Level_0 - -- - -- the mechanism is to create each object, "pushing" the existing list - -- onto the end: cons( new_item, car, cdr ) - - The_List := - new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null ); - -- Level_0 >> A - - The_List := - new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List ); - -- Level_1 -> Level_0 >> AC - - The_List := - new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List ); - -- Level_2 -> Level_1 -> Level_0 >> ACE - - The_List := - new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List ); - -- Level_1 -> Level_2 -> Level_1 -> Level_0 >> AC - - The_List := - new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List ); - -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 >> ACE - - end Build_List; - - procedure Traverse_List is - - Next_Item : List_Pointer := The_List; - - -- Check that if a function call with a controlling result is itself - -- a controlling operand of an enclosing call on a dispatching operation, - -- then its controlling tag value is determined by the controlling tag - -- value of the enclosing call. - - -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 - - begin - - while Next_Item /= null loop -- here we go! - -- these calls better dispatch according to the value in the particular - -- list item; causing the call to create to dispatch accordingly. - -- why do it twice? To make sure order makes no difference - - C392011_0.Check(Next_Item.Data.all, C392011_0.Create); - -- Create will touch first, then Check touches - - C392011_0.Check(C392011_0.Create, Next_Item.Data.all); - - -- Here's what's s'pos'd to 'appen: - -- Check( Lev_2, Create ) >> ACEF - -- Check( Create, Lev_2 ) >> ACEF - -- Check( Lev_1, Create ) >> ACD - -- Check( Create, Lev_1 ) >> ACD - -- Check( Lev_2, Create ) >> ACEF - -- Check( Create, Lev_2 ) >> ACEF - -- Check( Lev_1, Create ) >> ACD - -- Check( Create, Lev_1 ) >> ACD - -- Check( Lev_0, Create ) >> AB - -- Check( Create, Lev_0 ) >> AB - - Next_Item := Next_Item.Next; - end loop; - end Traverse_List; - -end C392011_2.C392011_3; - -------------------------------------------------------------------- C392011 - -with Report; -with TCTouch; -with C392011_2.C392011_3; - -procedure C392011 is - -begin -- Main test procedure. - - Report.Test ("C392011", "Check that if a function call with a " & - "controlling result is itself a controlling " & - "operand of an enclosing call on a dispatching " & - "operation, then its controlling tag value is " & - "determined by the controlling tag value of " & - "the enclosing call" ); - - C392011_2.C392011_3.Build_List; - TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" ); - - C392011_2.C392011_3.Traverse_List; - TCTouch.Validate( "ACEFACEF" & - "ACDACD" & - "ACEFACEF" & - "ACDACD" & - "ABAB", - "Traverse List" ); - - Report.Result; - -end C392011; |