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