diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392010.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c392010.a | 512 |
1 files changed, 0 insertions, 512 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392010.a b/gcc/testsuite/ada/acats/tests/c3/c392010.a deleted file mode 100644 index ec168780cbf..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392010.a +++ /dev/null @@ -1,512 +0,0 @@ --- C392010.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 a subprogram dispatches correctly with a controlling --- access parameter. Check that a subprogram dispatches correctly --- when it has access parameters that are not controlling. --- Check with and without default expressions. --- --- TEST DESCRIPTION: --- The three packages define layers of tagged types. The root tagged --- type contains a character value used to check that the right object --- got passed to the right routine. Each subprogram has a unique --- TCTouch tag, upper case values are used for subprograms, lower case --- values are used for object values. --- --- Notes on style: the "tagged" comment lines --I and --A represent --- commentary about what gets inherited and what becomes abstract, --- respectively. The author felt these to be necessary with this test --- to reduce some of the additional complexities. --- ---3.9.2(16,17,18,20);6.0 --- --- CHANGE HISTORY: --- 22 SEP 95 SAIC Initial version --- 22 APR 96 SAIC Revised for 2.1 --- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make --- it override. --- 21 JUN 00 RLB Changed expected result to reflect the appropriate --- value of the default expression. --- 20 JUL 00 RLB Removed entire call pending resolution by the ARG. - ---! - ------------------------------------------------------------------ C392010_0 - -package C392010_0 is - - -- define a root tagged type - type Tagtype_Level_0 is tagged record - Ch_Item : Character; - end record; - - type Access_Procedure is access procedure( P: Tagtype_Level_0 ); - - procedure Proc_1( P: Tagtype_Level_0 ); - - procedure Proc_2( P: Tagtype_Level_0 ); - - function A_Default_Value return Tagtype_Level_0; - - procedure Proc_w_Ap_and_Cp( AP : Access_Procedure; - Cp : Tagtype_Level_0 ); - -- has both access procedure and controlling parameter - - procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access; - Cp : Tagtype_Level_0 - := A_Default_Value ); ------------ z - -- has both access procedure and controlling parameter with defaults - - -- for the objective: --- Check that access parameters may be controlling. - - procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ); - -- has access parameter that is controlling - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 ) - return Tagtype_Level_0; - -- has access parameter that is controlling, and controlling result - - Level_0_Global_Object : aliased Tagtype_Level_0 - := ( Ch_Item => 'a' ); ---------------------------- a - -end C392010_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C392010_0 is - - procedure Proc_1( P: Tagtype_Level_0 ) is - begin - TCTouch.Touch('A'); --------------------------------------------------- A - TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ? - end Proc_1; - - procedure Proc_2( P: Tagtype_Level_0 ) is - begin - TCTouch.Touch('B'); --------------------------------------------------- B - TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ? - end Proc_2; - - function A_Default_Value return Tagtype_Level_0 is - begin - return (Ch_Item => 'z'); ---------------------------------------------- z - end A_Default_Value; - - procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure; - Cp : Tagtype_Level_0 ) is - begin - TCTouch.Touch('C'); --------------------------------------------------- C - Ap.all( Cp ); - end Proc_w_Ap_and_Cp; - - procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access; - Cp : Tagtype_Level_0 - := A_Default_Value ) is - begin - TCTouch.Touch('D'); --------------------------------------------------- D - Ap.all( Cp ); - end Proc_w_Ap_and_Cp_w_Def; - - procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is - begin - TCTouch.Touch('E'); --------------------------------------------------- E - TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? - end Proc_w_Cp_Ap; - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 ) - return Tagtype_Level_0 is - begin - TCTouch.Touch('F'); --------------------------------------------------- F - TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? - return ( Ch_Item => 'b' ); -------------------------------------------- b - end Func_w_Cp_Ap_and_Cr; - -end C392010_0; - ------------------------------------------------------------------ C392010_1 - -with C392010_0; -package C392010_1 is - - type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record - Int_Item : Integer; - end record; - - type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class; - - -- the following procedures are inherited by the above declaration: - --I procedure Proc_1( P: Tagtype_Level_1 ); - --I - --I procedure Proc_2( P: Tagtype_Level_1 ); - --I - --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; - --I Cp : Tagtype_Level_1 ); - --I - --I procedure Proc_w_Ap_and_Cp_w_Def - --I ( AP : C392010_0.Access_Procedure := Proc_2'Access; - --I Cp : Tagtype_Level_1 := A_Default_Value ); - --I - --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ); - --I - - -- the following functions become abstract due to the above declaration: - --A function A_Default_Value return Tagtype_Level_1; - --A - --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) - --A return Tagtype_Level_1; - - -- so, in the interest of testing dispatching, we override them all: - -- except Proc_1 and Proc_2 - - procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; - Cp : Tagtype_Level_1 ); - - function A_Default_Value return Tagtype_Level_1; - - procedure Proc_w_Ap_and_Cp_w_Def( - AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access; - Cp : Tagtype_Level_1 := A_Default_Value ); - - procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ); - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) - return Tagtype_Level_1; - - -- to test the objective: --- Check that a subprogram dispatches correctly when it has --- access parameters that are not controlling. - - procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := C392010_0.Level_0_Global_Object'Access ); - - function Func_w_Non( Cp_Ap : access Tagtype_Level_1; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := C392010_0.Level_0_Global_Object'Access ) - return Access_Tagtype_Level_1; - - Level_1_Global_Object : aliased Tagtype_Level_1 - := ( Int_Item => 0, - Ch_Item => 'c' ); --------------------------- c - -end C392010_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -package body C392010_1 is - - procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; - Cp : Tagtype_Level_1 ) is - begin - TCTouch.Touch('G'); --------------------------------------------------- G - Ap.All( C392010_0.Tagtype_Level_0( Cp ) ); - end Proc_w_Ap_and_Cp; - - procedure Proc_w_Ap_and_Cp_w_Def( - AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access; - Cp : Tagtype_Level_1 := A_Default_Value ) - is - begin - TCTouch.Touch('H'); --------------------------------------------------- H - Ap.All( C392010_0.Tagtype_Level_0( Cp ) ); - end Proc_w_Ap_and_Cp_w_Def; - - procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is - begin - TCTouch.Touch('I'); --------------------------------------------------- I - TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? - end Proc_w_Cp_Ap; - - function A_Default_Value return Tagtype_Level_1 is - begin - return ( Int_Item => 0, Ch_Item => 'y' ); ---------------------------- y - end A_Default_Value; - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) - return Tagtype_Level_1 is - begin - TCTouch.Touch('J'); --------------------------------------------------- J - TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? - return ( Int_Item => 2, Ch_Item => 'd' ); ----------------------------- d - end Func_w_Cp_Ap_and_Cr; - - procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := C392010_0.Level_0_Global_Object'Access ) is - begin - TCTouch.Touch('K'); --------------------------------------------------- K - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? - end Proc_w_Non; - - Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' ); - - function Func_w_Non( Cp_Ap : access Tagtype_Level_1; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := C392010_0.Level_0_Global_Object'Access ) - return Access_Tagtype_Level_1 is - begin - TCTouch.Touch('L'); --------------------------------------------------- L - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? - return Own_Item'Access; ----------------------------------------------- e - end Func_w_Non; - -end C392010_1; - - - ------------------------------------------------------------------ C392010_2 - -with C392010_0; -with C392010_1; -package C392010_2 is - - Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0 - := ( Ch_Item => 'f' ); ---------------------------- f - - type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record - Another_Int_Item : Integer; - end record; - - type Access_Tagtype_Level_2 is access all Tagtype_Level_2; - - -- the following procedures are inherited by the above declaration: - --I procedure Proc_1( P: Tagtype_Level_2 ); - --I - --I procedure Proc_2( P: Tagtype_Level_2 ); - --I - --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; - --I Cp : Tagtype_Level_2 ); - --I - --I procedure Proc_w_Ap_and_Cp_w_Def - --I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access; - --I CP: Tagtype_Level_2 := A_Default_Value ); - --I - --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 ); - --I - --I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; - --I NonCp_Ap : access C392010_0.Tagtype_Level_0 - --I := C392010_0.Level_0_Global_Object'Access ); - - -- the following functions become abstract due to the above declaration: - --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) - --A return Tagtype_Level_2; - --A - --A function A_Default_Value - --A return Access_Tagtype_Level_2; - - -- so we override the interesting ones to check the objective: --- Check that a subprogram with parameters of distinct tagged types may --- be primitive for only one type (i.e. the other tagged types must be --- declared in other packages). Check that the subprogram does not --- dispatch for the other type(s). - - procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := Lev2_Level_0_Global_Object'Access ); - - function Func_w_Non( Cp_Ap : access Tagtype_Level_2; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := Lev2_Level_0_Global_Object'Access ) - return C392010_1.Access_Tagtype_Level_1; - - -- and override the other abstract functions - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) - return Tagtype_Level_2; - - function A_Default_Value return Tagtype_Level_2; - -end C392010_2; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -with Report; -package body C392010_2 is - - procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := Lev2_Level_0_Global_Object'Access ) is - begin - TCTouch.Touch('M'); --------------------------------------------------- M - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? - end Proc_w_Non; - - function A_Default_Value return Tagtype_Level_2 is - begin - return ( Another_Int_Item | Int_Item => 0, Ch_Item => 'x' ); -------- x - end A_Default_Value; - - Own : aliased Tagtype_Level_2 - := ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' ); - - function Func_w_Non( Cp_Ap : access Tagtype_Level_2; - NonCp_Ap : access C392010_0.Tagtype_Level_0 - := Lev2_Level_0_Global_Object'Access ) - return C392010_1.Access_Tagtype_Level_1 is - begin - TCTouch.Touch('N'); --------------------------------------------------- N - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? - return Own'Access; ---------------------------------------------------- g - end Func_w_Non; - - function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) - return Tagtype_Level_2 is - begin - TCTouch.Touch('P'); --------------------------------------------------- P - TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? - return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' ); ---------- h - end Func_w_Cp_Ap_and_Cr; - -end C392010_2; - - - -------------------------------------------------------------------- C392010 - -with Report; -with TCTouch; -with C392010_0, C392010_1, C392010_2; - -procedure C392010 is - - type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class; - - -- define an array of class-wide pointers: - type Zero_Dispatch_List is array(Natural range <>) of Access_Class_0; - - Item_0 : aliased C392010_0.Tagtype_Level_0 := ( Ch_Item => 'k' ); ------ k - Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'm', ------ m - Int_Item => 1 ); - Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'n', ------ n - Int_Item => 1, - Another_Int_Item => 1 ); - - Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access); - - procedure Subtest_1( Items: Zero_Dispatch_List ) is - -- there is little difference between the actions for _1 and _2 in - -- this subtest due to the nature of _2 inheriting most operations - -- - -- this subtest checks operations available to Level_0'Class - begin - for I in Items'Range loop - - C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all ); - -- CAk, GAm, GAn - -- actual is class-wide, operation should dispatch - - case I is -- use defaults - when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def; - -- DBz - when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def; - -- HBy - when 3 => null; -- Removed following pending resolution by ARG - -- (see AI-00239): - -- C392010_2.Proc_w_Ap_and_Cp_w_Def; - -- HBx - when others => Report.Failed("Unexpected loop value"); - end case; - - C392010_0.Proc_w_Ap_and_Cp_w_Def -- override defaults - ( C392010_0.Proc_1'Access, Items(I).all ); - -- DAk, HAm, HAn - - C392010_0.Proc_w_Cp_Ap( Items(I) ); - -- Ek, Im, In - - -- function return value is controlling for procedure call - C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access, - C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) ); - -- FkDAb, JmHAd, PnHAh - -- note that the function evaluates first - - end loop; - end Subtest_1; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - type Access_Class_1 is access all C392010_1.Tagtype_Level_1'Class; - - type One_Dispatch_List is array(Natural range <>) of Access_Class_1; - - Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'p', ----- p - Int_Item => 1 ); - Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'q', ----- q - Int_Item => 1, - Another_Int_Item => 1 ); - - D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access); - - procedure Subtest_2( Items: One_Dispatch_List ) is - -- this subtest checks operations available to Level_1'Class, - -- specifically those operations that are not testable in subtest_1, - -- the operations with parameters of the two tagged type objects. - begin - for I in Items'Range loop - - C392010_1.Proc_w_Non( -- t_1, t_2 - C392010_1.Func_w_Non( Items(I), - C392010_0.Tagtype_Level_0(Z(I).all)'Access ), -- Lpk Nqm - C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem Mgn - - end loop; - end Subtest_2; - -begin -- Main test procedure. - - Report.Test ("C392010", "Check that a subprogram dispatches correctly " & - "with a controlling access parameter. " & - "Check that a subprogram dispatches correctly " & - "when it has access parameters that are not " & - "controlling. Check with and without default " & - "expressions" ); - - Subtest_1( Z ); - - -- Original result: - --TCTouch.Validate( "CAkDBzDAkEkFkDAb" - -- & "GAmHByHAmImJmHAd" - -- & "GAnHBxHAnInPnHAh", "Subtest 1" ); - - -- Result pending resultion of AI-239: - TCTouch.Validate( "CAkDBzDAkEkFkDAb" - & "GAmHByHAmImJmHAd" - & "GAnHAnInPnHAh", "Subtest 1" ); - - Subtest_2( D ); - - TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" ); - - Report.Result; - -end C392010; |