-- C360002.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 modular types may be used as array indices. -- -- Check that if aliased appears in the component_definition of an -- array_type that each component of the array is aliased. -- -- Check that references to aliased array objects produce correct -- results, and that out-of-bounds indexing correctly produces -- Constraint_Error. -- -- TEST DESCRIPTION: -- This test defines several array types and subtypes indexed by modular -- types; some aliased some not, some with aliased components, some not. -- -- It then checks that assignments move the correct data. -- -- -- CHANGE HISTORY: -- 28 SEP 95 SAIC Initial version -- 23 APR 96 SAIC Doc fixes, fixed constrained/unconstrained conflict -- 13 FEB 97 PWB.CTA Removed illegal declarations and affected code --! ------------------------------------------------------------------- C360002 with Report; procedure C360002 is Verbose : Boolean := Report.Ident_Bool( False ); type Mod_128 is mod 128; function Ident_128( I: Integer ) return Mod_128 is begin return Mod_128( Report.Ident_Int( I ) ); end Ident_128; type Unconstrained_Array is array( Mod_128 range <> ) of Integer; type Unconstrained_Array_Aliased is array( Mod_128 range <> ) of aliased Integer; type Access_All_Unconstrained_Array is access all Unconstrained_Array; type Access_All_Unconstrained_Array_Aliased is access all Unconstrained_Array_Aliased; subtype Array_01_10 is Unconstrained_Array(01..10); subtype Array_11_20 is Unconstrained_Array(11..20); subtype Array_Aliased_01_10 is Unconstrained_Array_Aliased(01..10); subtype Array_Aliased_11_20 is Unconstrained_Array_Aliased(11..20); subtype Access_All_01_10_Array is Access_All_Unconstrained_Array(01..10); subtype Access_All_01_10_Array_Aliased is Access_All_Unconstrained_Array_Aliased(01..10); subtype Access_All_11_20_Array is Access_All_Unconstrained_Array(11..20); subtype Access_All_11_20_Array_Aliased is Access_All_Unconstrained_Array_Aliased(11..20); -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- these 'filler' functions create unique values for every element that -- is used and/or tested in this test. Well_Bottom : Integer := 0; function Filler( Size : Mod_128 ) return Unconstrained_Array is It : Unconstrained_Array( 0..Size-1 ); begin for Eyes in It'Range loop It(Eyes) := Integer( Eyes ) + Well_Bottom; end loop; Well_Bottom := Well_Bottom + It'Length; return It; end Filler; function Filler( Size : Mod_128 ) return Unconstrained_Array_Aliased is It : Unconstrained_Array_Aliased( 0..Size-1 ); begin for Ayes in It'Range loop It(Ayes) := Integer( Ayes ) + Well_Bottom; end loop; Well_Bottom := Well_Bottom + It'Length; return It; end Filler; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- An_Integer : Integer; type AAI is access all Integer; An_Integer_Access : AAI; Array_Item_01_10 : Array_01_10 := Filler(10); -- 0..9 Array_Item_11_20 : Array_11_20 := Filler(10); -- 10..19 (sliding) Array_Aliased_Item_01_10 : Array_Aliased_01_10 := Filler(10); -- 20..29 Array_Aliased_Item_11_20 : Array_Aliased_11_20 := Filler(10); -- 30..39 Aliased_Array_Item_01_10 : aliased Array_01_10 := Filler(10); -- 40..49 Aliased_Array_Item_11_20 : aliased Array_11_20 := Filler(10); -- 50..59 Aliased_Array_Aliased_Item_01_10 : aliased Array_Aliased_01_10 := Filler(10); -- 60..69 Aliased_Array_Aliased_Item_11_20 : aliased Array_Aliased_11_20 := Filler(10); -- 70..79 Check_Item : Access_All_Unconstrained_Array; Check_Aliased_Item : Access_All_Unconstrained_Array_Aliased; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- procedure Fail( Message : String; CI, SB : Integer ) is begin Report.Failed("Wrong value passed " & Message); if Verbose then Report.Comment("got" & Integer'Image(CI) & " should be" & Integer'Image(SB) ); end if; end Fail; procedure Check_Array_01_10( Checked_Item : Array_01_10; Low_SB : Integer ) is begin for Index in Checked_Item'Range loop if (Checked_Item(Index) /= (Low_SB +Integer(Index)-1)) then Fail("unaliased 1..10", Checked_Item(Index), (Low_SB +Integer(Index)-1)); end if; end loop; end Check_Array_01_10; procedure Check_Array_11_20( Checked_Item : Array_11_20; Low_SB : Integer ) is begin for Index in Checked_Item'Range loop if (Checked_Item(Index) /= (Low_SB +Integer(Index)-11)) then Fail("unaliased 11..20", Checked_Item(Index), (Low_SB +Integer(Index)-11)); end if; end loop; end Check_Array_11_20; procedure Check_Single_Integer( The_Integer, SB : Integer; Message : String ) is begin if The_Integer /= SB then Report.Failed("Wrong integer value for " & Message ); end if; end Check_Single_Integer; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- begin -- Main test procedure. Report.Test ("C360002", "Check that modular types may be used as array " & "indices. Check that if aliased appears in " & "the component_definition of an array_type that " & "each component of the array is aliased. Check " & "that references to aliased array objects " & "produce correct results, and that out of bound " & "references to aliased objects correctly " & "produce Constraint_Error" ); -- start with checks that the Filler assignments produced the expected -- result. This is a "case 0" test to check that nothing REALLY surprising -- is happening Check_Array_01_10( Array_Item_01_10, 0 ); Check_Array_11_20( Array_Item_11_20, 10 ); -- check that having the variable aliased makes no difference Check_Array_01_10( Aliased_Array_Item_01_10, 40 ); Check_Array_11_20( Aliased_Array_Item_11_20, 50 ); -- now check that conversion between array types where the only -- difference in the definitions is that the components are aliased works Check_Array_01_10( Unconstrained_Array( Array_Aliased_Item_01_10 ), 20 ); Check_Array_11_20( Unconstrained_Array( Array_Aliased_Item_11_20 ), 30 ); -- check that conversion of an aliased object with aliased components -- also works Check_Array_01_10( Unconstrained_Array( Aliased_Array_Aliased_Item_01_10 ), 60 ); Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ), 70 ); -- check that the bounds will slide Check_Array_01_10( Array_01_10( Array_Item_11_20 ), 10 ); Check_Array_11_20( Array_11_20( Array_Item_01_10 ), 0 ); -- point at some of the components and check them An_Integer_Access := Array_Aliased_Item_01_10(5)'Access; Check_Single_Integer( An_Integer_Access.all, 24, "Aliased component 'Access"); An_Integer_Access := Aliased_Array_Aliased_Item_01_10(7)'Access; Check_Single_Integer( An_Integer_Access.all, 66, "Aliased Aliased component 'Access"); -- check some assignments Array_Item_01_10 := Aliased_Array_Item_01_10; Check_Array_01_10( Array_Item_01_10, 40 ); Aliased_Array_Item_01_10 := Aliased_Array_Item_11_20(11..20); Check_Array_01_10( Aliased_Array_Item_01_10, 50 ); Aliased_Array_Aliased_Item_11_20(11..20) := Aliased_Array_Aliased_Item_01_10; Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ), 60 ); Report.Result; end C360002;