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