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