-- C392010.A
|
-- C392010.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that a subprogram dispatches correctly with a controlling
|
-- Check that a subprogram dispatches correctly with a controlling
|
-- access parameter. Check that a subprogram dispatches correctly
|
-- access parameter. Check that a subprogram dispatches correctly
|
-- when it has access parameters that are not controlling.
|
-- when it has access parameters that are not controlling.
|
-- Check with and without default expressions.
|
-- Check with and without default expressions.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- The three packages define layers of tagged types. The root tagged
|
-- The three packages define layers of tagged types. The root tagged
|
-- type contains a character value used to check that the right object
|
-- type contains a character value used to check that the right object
|
-- got passed to the right routine. Each subprogram has a unique
|
-- got passed to the right routine. Each subprogram has a unique
|
-- TCTouch tag, upper case values are used for subprograms, lower case
|
-- TCTouch tag, upper case values are used for subprograms, lower case
|
-- values are used for object values.
|
-- values are used for object values.
|
--
|
--
|
-- Notes on style: the "tagged" comment lines --I and --A represent
|
-- Notes on style: the "tagged" comment lines --I and --A represent
|
-- commentary about what gets inherited and what becomes abstract,
|
-- commentary about what gets inherited and what becomes abstract,
|
-- respectively. The author felt these to be necessary with this test
|
-- respectively. The author felt these to be necessary with this test
|
-- to reduce some of the additional complexities.
|
-- to reduce some of the additional complexities.
|
--
|
--
|
--3.9.2(16,17,18,20);6.0
|
--3.9.2(16,17,18,20);6.0
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 22 SEP 95 SAIC Initial version
|
-- 22 SEP 95 SAIC Initial version
|
-- 22 APR 96 SAIC Revised for 2.1
|
-- 22 APR 96 SAIC Revised for 2.1
|
-- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make
|
-- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make
|
-- it override.
|
-- it override.
|
-- 21 JUN 00 RLB Changed expected result to reflect the appropriate
|
-- 21 JUN 00 RLB Changed expected result to reflect the appropriate
|
-- value of the default expression.
|
-- value of the default expression.
|
-- 20 JUL 00 RLB Removed entire call pending resolution by the ARG.
|
-- 20 JUL 00 RLB Removed entire call pending resolution by the ARG.
|
|
|
--!
|
--!
|
|
|
----------------------------------------------------------------- C392010_0
|
----------------------------------------------------------------- C392010_0
|
|
|
package C392010_0 is
|
package C392010_0 is
|
|
|
-- define a root tagged type
|
-- define a root tagged type
|
type Tagtype_Level_0 is tagged record
|
type Tagtype_Level_0 is tagged record
|
Ch_Item : Character;
|
Ch_Item : Character;
|
end record;
|
end record;
|
|
|
type Access_Procedure is access procedure( P: Tagtype_Level_0 );
|
type Access_Procedure is access procedure( P: Tagtype_Level_0 );
|
|
|
procedure Proc_1( P: Tagtype_Level_0 );
|
procedure Proc_1( P: Tagtype_Level_0 );
|
|
|
procedure Proc_2( P: Tagtype_Level_0 );
|
procedure Proc_2( P: Tagtype_Level_0 );
|
|
|
function A_Default_Value return Tagtype_Level_0;
|
function A_Default_Value return Tagtype_Level_0;
|
|
|
procedure Proc_w_Ap_and_Cp( AP : Access_Procedure;
|
procedure Proc_w_Ap_and_Cp( AP : Access_Procedure;
|
Cp : Tagtype_Level_0 );
|
Cp : Tagtype_Level_0 );
|
-- has both access procedure and controlling parameter
|
-- has both access procedure and controlling parameter
|
|
|
procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
|
procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
|
Cp : Tagtype_Level_0
|
Cp : Tagtype_Level_0
|
:= A_Default_Value ); ------------ z
|
:= A_Default_Value ); ------------ z
|
-- has both access procedure and controlling parameter with defaults
|
-- has both access procedure and controlling parameter with defaults
|
|
|
-- for the objective:
|
-- for the objective:
|
-- Check that access parameters may be controlling.
|
-- Check that access parameters may be controlling.
|
|
|
procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 );
|
procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 );
|
-- has access parameter that is controlling
|
-- has access parameter that is controlling
|
|
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
|
return Tagtype_Level_0;
|
return Tagtype_Level_0;
|
-- has access parameter that is controlling, and controlling result
|
-- has access parameter that is controlling, and controlling result
|
|
|
Level_0_Global_Object : aliased Tagtype_Level_0
|
Level_0_Global_Object : aliased Tagtype_Level_0
|
:= ( Ch_Item => 'a' ); ---------------------------- a
|
:= ( Ch_Item => 'a' ); ---------------------------- a
|
|
|
end C392010_0;
|
end C392010_0;
|
|
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C392010_0 is
|
package body C392010_0 is
|
|
|
procedure Proc_1( P: Tagtype_Level_0 ) is
|
procedure Proc_1( P: Tagtype_Level_0 ) is
|
begin
|
begin
|
TCTouch.Touch('A'); --------------------------------------------------- A
|
TCTouch.Touch('A'); --------------------------------------------------- A
|
TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ?
|
TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ?
|
end Proc_1;
|
end Proc_1;
|
|
|
procedure Proc_2( P: Tagtype_Level_0 ) is
|
procedure Proc_2( P: Tagtype_Level_0 ) is
|
begin
|
begin
|
TCTouch.Touch('B'); --------------------------------------------------- B
|
TCTouch.Touch('B'); --------------------------------------------------- B
|
TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ?
|
TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ?
|
end Proc_2;
|
end Proc_2;
|
|
|
function A_Default_Value return Tagtype_Level_0 is
|
function A_Default_Value return Tagtype_Level_0 is
|
begin
|
begin
|
return (Ch_Item => 'z'); ---------------------------------------------- z
|
return (Ch_Item => 'z'); ---------------------------------------------- z
|
end A_Default_Value;
|
end A_Default_Value;
|
|
|
procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure;
|
procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure;
|
Cp : Tagtype_Level_0 ) is
|
Cp : Tagtype_Level_0 ) is
|
begin
|
begin
|
TCTouch.Touch('C'); --------------------------------------------------- C
|
TCTouch.Touch('C'); --------------------------------------------------- C
|
Ap.all( Cp );
|
Ap.all( Cp );
|
end Proc_w_Ap_and_Cp;
|
end Proc_w_Ap_and_Cp;
|
|
|
procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
|
procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
|
Cp : Tagtype_Level_0
|
Cp : Tagtype_Level_0
|
:= A_Default_Value ) is
|
:= A_Default_Value ) is
|
begin
|
begin
|
TCTouch.Touch('D'); --------------------------------------------------- D
|
TCTouch.Touch('D'); --------------------------------------------------- D
|
Ap.all( Cp );
|
Ap.all( Cp );
|
end Proc_w_Ap_and_Cp_w_Def;
|
end Proc_w_Ap_and_Cp_w_Def;
|
|
|
procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is
|
procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is
|
begin
|
begin
|
TCTouch.Touch('E'); --------------------------------------------------- E
|
TCTouch.Touch('E'); --------------------------------------------------- E
|
TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
|
end Proc_w_Cp_Ap;
|
end Proc_w_Cp_Ap;
|
|
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
|
return Tagtype_Level_0 is
|
return Tagtype_Level_0 is
|
begin
|
begin
|
TCTouch.Touch('F'); --------------------------------------------------- F
|
TCTouch.Touch('F'); --------------------------------------------------- F
|
TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
|
return ( Ch_Item => 'b' ); -------------------------------------------- b
|
return ( Ch_Item => 'b' ); -------------------------------------------- b
|
end Func_w_Cp_Ap_and_Cr;
|
end Func_w_Cp_Ap_and_Cr;
|
|
|
end C392010_0;
|
end C392010_0;
|
|
|
----------------------------------------------------------------- C392010_1
|
----------------------------------------------------------------- C392010_1
|
|
|
with C392010_0;
|
with C392010_0;
|
package C392010_1 is
|
package C392010_1 is
|
|
|
type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record
|
type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record
|
Int_Item : Integer;
|
Int_Item : Integer;
|
end record;
|
end record;
|
|
|
type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class;
|
type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class;
|
|
|
-- the following procedures are inherited by the above declaration:
|
-- the following procedures are inherited by the above declaration:
|
--I procedure Proc_1( P: Tagtype_Level_1 );
|
--I procedure Proc_1( P: Tagtype_Level_1 );
|
--I
|
--I
|
--I procedure Proc_2( P: Tagtype_Level_1 );
|
--I procedure Proc_2( P: Tagtype_Level_1 );
|
--I
|
--I
|
--I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
|
--I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
|
--I Cp : Tagtype_Level_1 );
|
--I Cp : Tagtype_Level_1 );
|
--I
|
--I
|
--I procedure Proc_w_Ap_and_Cp_w_Def
|
--I procedure Proc_w_Ap_and_Cp_w_Def
|
--I ( AP : C392010_0.Access_Procedure := Proc_2'Access;
|
--I ( AP : C392010_0.Access_Procedure := Proc_2'Access;
|
--I Cp : Tagtype_Level_1 := A_Default_Value );
|
--I Cp : Tagtype_Level_1 := A_Default_Value );
|
--I
|
--I
|
--I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
|
--I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
|
--I
|
--I
|
|
|
-- the following functions become abstract due to the above declaration:
|
-- the following functions become abstract due to the above declaration:
|
--A function A_Default_Value return Tagtype_Level_1;
|
--A function A_Default_Value return Tagtype_Level_1;
|
--A
|
--A
|
--A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
|
--A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
|
--A return Tagtype_Level_1;
|
--A return Tagtype_Level_1;
|
|
|
-- so, in the interest of testing dispatching, we override them all:
|
-- so, in the interest of testing dispatching, we override them all:
|
-- except Proc_1 and Proc_2
|
-- except Proc_1 and Proc_2
|
|
|
procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
|
procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
|
Cp : Tagtype_Level_1 );
|
Cp : Tagtype_Level_1 );
|
|
|
function A_Default_Value return Tagtype_Level_1;
|
function A_Default_Value return Tagtype_Level_1;
|
|
|
procedure Proc_w_Ap_and_Cp_w_Def(
|
procedure Proc_w_Ap_and_Cp_w_Def(
|
AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
|
AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
|
Cp : Tagtype_Level_1 := A_Default_Value );
|
Cp : Tagtype_Level_1 := A_Default_Value );
|
|
|
procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
|
procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
|
|
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
|
return Tagtype_Level_1;
|
return Tagtype_Level_1;
|
|
|
-- to test the objective:
|
-- to test the objective:
|
-- Check that a subprogram dispatches correctly when it has
|
-- Check that a subprogram dispatches correctly when it has
|
-- access parameters that are not controlling.
|
-- access parameters that are not controlling.
|
|
|
procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1;
|
procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1;
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
:= C392010_0.Level_0_Global_Object'Access );
|
:= C392010_0.Level_0_Global_Object'Access );
|
|
|
function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
|
function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
:= C392010_0.Level_0_Global_Object'Access )
|
:= C392010_0.Level_0_Global_Object'Access )
|
return Access_Tagtype_Level_1;
|
return Access_Tagtype_Level_1;
|
|
|
Level_1_Global_Object : aliased Tagtype_Level_1
|
Level_1_Global_Object : aliased Tagtype_Level_1
|
:= ( Int_Item => 0,
|
:= ( Int_Item => 0,
|
Ch_Item => 'c' ); --------------------------- c
|
Ch_Item => 'c' ); --------------------------- c
|
|
|
end C392010_1;
|
end C392010_1;
|
|
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C392010_1 is
|
package body C392010_1 is
|
|
|
procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
|
procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
|
Cp : Tagtype_Level_1 ) is
|
Cp : Tagtype_Level_1 ) is
|
begin
|
begin
|
TCTouch.Touch('G'); --------------------------------------------------- G
|
TCTouch.Touch('G'); --------------------------------------------------- G
|
Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
|
Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
|
end Proc_w_Ap_and_Cp;
|
end Proc_w_Ap_and_Cp;
|
|
|
procedure Proc_w_Ap_and_Cp_w_Def(
|
procedure Proc_w_Ap_and_Cp_w_Def(
|
AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
|
AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
|
Cp : Tagtype_Level_1 := A_Default_Value )
|
Cp : Tagtype_Level_1 := A_Default_Value )
|
is
|
is
|
begin
|
begin
|
TCTouch.Touch('H'); --------------------------------------------------- H
|
TCTouch.Touch('H'); --------------------------------------------------- H
|
Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
|
Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
|
end Proc_w_Ap_and_Cp_w_Def;
|
end Proc_w_Ap_and_Cp_w_Def;
|
|
|
procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is
|
procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is
|
begin
|
begin
|
TCTouch.Touch('I'); --------------------------------------------------- I
|
TCTouch.Touch('I'); --------------------------------------------------- I
|
TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
|
end Proc_w_Cp_Ap;
|
end Proc_w_Cp_Ap;
|
|
|
function A_Default_Value return Tagtype_Level_1 is
|
function A_Default_Value return Tagtype_Level_1 is
|
begin
|
begin
|
return ( Int_Item => 0, Ch_Item => 'y' ); ---------------------------- y
|
return ( Int_Item => 0, Ch_Item => 'y' ); ---------------------------- y
|
end A_Default_Value;
|
end A_Default_Value;
|
|
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
|
return Tagtype_Level_1 is
|
return Tagtype_Level_1 is
|
begin
|
begin
|
TCTouch.Touch('J'); --------------------------------------------------- J
|
TCTouch.Touch('J'); --------------------------------------------------- J
|
TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
|
return ( Int_Item => 2, Ch_Item => 'd' ); ----------------------------- d
|
return ( Int_Item => 2, Ch_Item => 'd' ); ----------------------------- d
|
end Func_w_Cp_Ap_and_Cr;
|
end Func_w_Cp_Ap_and_Cr;
|
|
|
procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1;
|
procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1;
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
:= C392010_0.Level_0_Global_Object'Access ) is
|
:= C392010_0.Level_0_Global_Object'Access ) is
|
begin
|
begin
|
TCTouch.Touch('K'); --------------------------------------------------- K
|
TCTouch.Touch('K'); --------------------------------------------------- K
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
|
TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
|
end Proc_w_Non;
|
end Proc_w_Non;
|
|
|
Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' );
|
Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' );
|
|
|
function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
|
function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
:= C392010_0.Level_0_Global_Object'Access )
|
:= C392010_0.Level_0_Global_Object'Access )
|
return Access_Tagtype_Level_1 is
|
return Access_Tagtype_Level_1 is
|
begin
|
begin
|
TCTouch.Touch('L'); --------------------------------------------------- L
|
TCTouch.Touch('L'); --------------------------------------------------- L
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
|
TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
|
return Own_Item'Access; ----------------------------------------------- e
|
return Own_Item'Access; ----------------------------------------------- e
|
end Func_w_Non;
|
end Func_w_Non;
|
|
|
end C392010_1;
|
end C392010_1;
|
|
|
|
|
|
|
----------------------------------------------------------------- C392010_2
|
----------------------------------------------------------------- C392010_2
|
|
|
with C392010_0;
|
with C392010_0;
|
with C392010_1;
|
with C392010_1;
|
package C392010_2 is
|
package C392010_2 is
|
|
|
Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0
|
Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0
|
:= ( Ch_Item => 'f' ); ---------------------------- f
|
:= ( Ch_Item => 'f' ); ---------------------------- f
|
|
|
type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record
|
type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record
|
Another_Int_Item : Integer;
|
Another_Int_Item : Integer;
|
end record;
|
end record;
|
|
|
type Access_Tagtype_Level_2 is access all Tagtype_Level_2;
|
type Access_Tagtype_Level_2 is access all Tagtype_Level_2;
|
|
|
-- the following procedures are inherited by the above declaration:
|
-- the following procedures are inherited by the above declaration:
|
--I procedure Proc_1( P: Tagtype_Level_2 );
|
--I procedure Proc_1( P: Tagtype_Level_2 );
|
--I
|
--I
|
--I procedure Proc_2( P: Tagtype_Level_2 );
|
--I procedure Proc_2( P: Tagtype_Level_2 );
|
--I
|
--I
|
--I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
|
--I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
|
--I Cp : Tagtype_Level_2 );
|
--I Cp : Tagtype_Level_2 );
|
--I
|
--I
|
--I procedure Proc_w_Ap_and_Cp_w_Def
|
--I procedure Proc_w_Ap_and_Cp_w_Def
|
--I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access;
|
--I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access;
|
--I CP: Tagtype_Level_2 := A_Default_Value );
|
--I CP: Tagtype_Level_2 := A_Default_Value );
|
--I
|
--I
|
--I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 );
|
--I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 );
|
--I
|
--I
|
--I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
|
--I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
|
--I NonCp_Ap : access C392010_0.Tagtype_Level_0
|
--I NonCp_Ap : access C392010_0.Tagtype_Level_0
|
--I := C392010_0.Level_0_Global_Object'Access );
|
--I := C392010_0.Level_0_Global_Object'Access );
|
|
|
-- the following functions become abstract due to the above declaration:
|
-- 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 function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
|
--A return Tagtype_Level_2;
|
--A return Tagtype_Level_2;
|
--A
|
--A
|
--A function A_Default_Value
|
--A function A_Default_Value
|
--A return Access_Tagtype_Level_2;
|
--A return Access_Tagtype_Level_2;
|
|
|
-- so we override the interesting ones to check the objective:
|
-- so we override the interesting ones to check the objective:
|
-- Check that a subprogram with parameters of distinct tagged types may
|
-- 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
|
-- be primitive for only one type (i.e. the other tagged types must be
|
-- declared in other packages). Check that the subprogram does not
|
-- declared in other packages). Check that the subprogram does not
|
-- dispatch for the other type(s).
|
-- dispatch for the other type(s).
|
|
|
procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
|
procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
:= Lev2_Level_0_Global_Object'Access );
|
:= Lev2_Level_0_Global_Object'Access );
|
|
|
function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
|
function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
:= Lev2_Level_0_Global_Object'Access )
|
:= Lev2_Level_0_Global_Object'Access )
|
return C392010_1.Access_Tagtype_Level_1;
|
return C392010_1.Access_Tagtype_Level_1;
|
|
|
-- and override the other abstract functions
|
-- and override the other abstract functions
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
|
return Tagtype_Level_2;
|
return Tagtype_Level_2;
|
|
|
function A_Default_Value return Tagtype_Level_2;
|
function A_Default_Value return Tagtype_Level_2;
|
|
|
end C392010_2;
|
end C392010_2;
|
|
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
|
|
with TCTouch;
|
with TCTouch;
|
with Report;
|
with Report;
|
package body C392010_2 is
|
package body C392010_2 is
|
|
|
procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
|
procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
:= Lev2_Level_0_Global_Object'Access ) is
|
:= Lev2_Level_0_Global_Object'Access ) is
|
begin
|
begin
|
TCTouch.Touch('M'); --------------------------------------------------- M
|
TCTouch.Touch('M'); --------------------------------------------------- M
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
|
TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
|
end Proc_w_Non;
|
end Proc_w_Non;
|
|
|
function A_Default_Value return Tagtype_Level_2 is
|
function A_Default_Value return Tagtype_Level_2 is
|
begin
|
begin
|
return ( Another_Int_Item | Int_Item => 0, Ch_Item => 'x' ); -------- x
|
return ( Another_Int_Item | Int_Item => 0, Ch_Item => 'x' ); -------- x
|
end A_Default_Value;
|
end A_Default_Value;
|
|
|
Own : aliased Tagtype_Level_2
|
Own : aliased Tagtype_Level_2
|
:= ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' );
|
:= ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' );
|
|
|
function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
|
function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
NonCp_Ap : access C392010_0.Tagtype_Level_0
|
:= Lev2_Level_0_Global_Object'Access )
|
:= Lev2_Level_0_Global_Object'Access )
|
return C392010_1.Access_Tagtype_Level_1 is
|
return C392010_1.Access_Tagtype_Level_1 is
|
begin
|
begin
|
TCTouch.Touch('N'); --------------------------------------------------- N
|
TCTouch.Touch('N'); --------------------------------------------------- N
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
|
TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
|
return Own'Access; ---------------------------------------------------- g
|
return Own'Access; ---------------------------------------------------- g
|
end Func_w_Non;
|
end Func_w_Non;
|
|
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
|
function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
|
return Tagtype_Level_2 is
|
return Tagtype_Level_2 is
|
begin
|
begin
|
TCTouch.Touch('P'); --------------------------------------------------- P
|
TCTouch.Touch('P'); --------------------------------------------------- P
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
|
return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' ); ---------- h
|
return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' ); ---------- h
|
end Func_w_Cp_Ap_and_Cr;
|
end Func_w_Cp_Ap_and_Cr;
|
|
|
end C392010_2;
|
end C392010_2;
|
|
|
|
|
|
|
------------------------------------------------------------------- C392010
|
------------------------------------------------------------------- C392010
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
with C392010_0, C392010_1, C392010_2;
|
with C392010_0, C392010_1, C392010_2;
|
|
|
procedure C392010 is
|
procedure C392010 is
|
|
|
type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class;
|
type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class;
|
|
|
-- define an array of class-wide pointers:
|
-- define an array of class-wide pointers:
|
type Zero_Dispatch_List is array(Natural range <>) of Access_Class_0;
|
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_0 : aliased C392010_0.Tagtype_Level_0 := ( Ch_Item => 'k' ); ------ k
|
Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'm', ------ m
|
Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'm', ------ m
|
Int_Item => 1 );
|
Int_Item => 1 );
|
Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'n', ------ n
|
Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'n', ------ n
|
Int_Item => 1,
|
Int_Item => 1,
|
Another_Int_Item => 1 );
|
Another_Int_Item => 1 );
|
|
|
Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access);
|
Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access);
|
|
|
procedure Subtest_1( Items: Zero_Dispatch_List ) is
|
procedure Subtest_1( Items: Zero_Dispatch_List ) is
|
-- there is little difference between the actions for _1 and _2 in
|
-- 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 due to the nature of _2 inheriting most operations
|
--
|
--
|
-- this subtest checks operations available to Level_0'Class
|
-- this subtest checks operations available to Level_0'Class
|
begin
|
begin
|
for I in Items'Range loop
|
for I in Items'Range loop
|
|
|
C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all );
|
C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all );
|
-- CAk, GAm, GAn
|
-- CAk, GAm, GAn
|
-- actual is class-wide, operation should dispatch
|
-- actual is class-wide, operation should dispatch
|
|
|
case I is -- use defaults
|
case I is -- use defaults
|
when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def;
|
when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def;
|
-- DBz
|
-- DBz
|
when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def;
|
when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def;
|
-- HBy
|
-- HBy
|
when 3 => null; -- Removed following pending resolution by ARG
|
when 3 => null; -- Removed following pending resolution by ARG
|
-- (see AI-00239):
|
-- (see AI-00239):
|
-- C392010_2.Proc_w_Ap_and_Cp_w_Def;
|
-- C392010_2.Proc_w_Ap_and_Cp_w_Def;
|
-- HBx
|
-- HBx
|
when others => Report.Failed("Unexpected loop value");
|
when others => Report.Failed("Unexpected loop value");
|
end case;
|
end case;
|
|
|
C392010_0.Proc_w_Ap_and_Cp_w_Def -- override defaults
|
C392010_0.Proc_w_Ap_and_Cp_w_Def -- override defaults
|
( C392010_0.Proc_1'Access, Items(I).all );
|
( C392010_0.Proc_1'Access, Items(I).all );
|
-- DAk, HAm, HAn
|
-- DAk, HAm, HAn
|
|
|
C392010_0.Proc_w_Cp_Ap( Items(I) );
|
C392010_0.Proc_w_Cp_Ap( Items(I) );
|
-- Ek, Im, In
|
-- Ek, Im, In
|
|
|
-- function return value is controlling for procedure call
|
-- function return value is controlling for procedure call
|
C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access,
|
C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access,
|
C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) );
|
C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) );
|
-- FkDAb, JmHAd, PnHAh
|
-- FkDAb, JmHAd, PnHAh
|
-- note that the function evaluates first
|
-- note that the function evaluates first
|
|
|
end loop;
|
end loop;
|
end Subtest_1;
|
end Subtest_1;
|
|
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
|
|
|
type Access_Class_1 is access all C392010_1.Tagtype_Level_1'Class;
|
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;
|
type One_Dispatch_List is array(Natural range <>) of Access_Class_1;
|
|
|
Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'p', ----- p
|
Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'p', ----- p
|
Int_Item => 1 );
|
Int_Item => 1 );
|
Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'q', ----- q
|
Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'q', ----- q
|
Int_Item => 1,
|
Int_Item => 1,
|
Another_Int_Item => 1 );
|
Another_Int_Item => 1 );
|
|
|
D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access);
|
D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access);
|
|
|
procedure Subtest_2( Items: One_Dispatch_List ) is
|
procedure Subtest_2( Items: One_Dispatch_List ) is
|
-- this subtest checks operations available to Level_1'Class,
|
-- this subtest checks operations available to Level_1'Class,
|
-- specifically those operations that are not testable in subtest_1,
|
-- specifically those operations that are not testable in subtest_1,
|
-- the operations with parameters of the two tagged type objects.
|
-- the operations with parameters of the two tagged type objects.
|
begin
|
begin
|
for I in Items'Range loop
|
for I in Items'Range loop
|
|
|
C392010_1.Proc_w_Non( -- t_1, t_2
|
C392010_1.Proc_w_Non( -- t_1, t_2
|
C392010_1.Func_w_Non( Items(I),
|
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).all)'Access ), -- Lpk Nqm
|
C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem Mgn
|
C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem Mgn
|
|
|
end loop;
|
end loop;
|
end Subtest_2;
|
end Subtest_2;
|
|
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
Report.Test ("C392010", "Check that a subprogram dispatches correctly " &
|
Report.Test ("C392010", "Check that a subprogram dispatches correctly " &
|
"with a controlling access parameter. " &
|
"with a controlling access parameter. " &
|
"Check that a subprogram dispatches correctly " &
|
"Check that a subprogram dispatches correctly " &
|
"when it has access parameters that are not " &
|
"when it has access parameters that are not " &
|
"controlling. Check with and without default " &
|
"controlling. Check with and without default " &
|
"expressions" );
|
"expressions" );
|
|
|
Subtest_1( Z );
|
Subtest_1( Z );
|
|
|
-- Original result:
|
-- Original result:
|
--TCTouch.Validate( "CAkDBzDAkEkFkDAb"
|
--TCTouch.Validate( "CAkDBzDAkEkFkDAb"
|
-- & "GAmHByHAmImJmHAd"
|
-- & "GAmHByHAmImJmHAd"
|
-- & "GAnHBxHAnInPnHAh", "Subtest 1" );
|
-- & "GAnHBxHAnInPnHAh", "Subtest 1" );
|
|
|
-- Result pending resultion of AI-239:
|
-- Result pending resultion of AI-239:
|
TCTouch.Validate( "CAkDBzDAkEkFkDAb"
|
TCTouch.Validate( "CAkDBzDAkEkFkDAb"
|
& "GAmHByHAmImJmHAd"
|
& "GAmHByHAmImJmHAd"
|
& "GAnHAnInPnHAh", "Subtest 1" );
|
& "GAnHAnInPnHAh", "Subtest 1" );
|
|
|
Subtest_2( D );
|
Subtest_2( D );
|
|
|
TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" );
|
TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" );
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C392010;
|
end C392010;
|
|
|