URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c392010.a] - Rev 384
Compare with Previous | Blame | View Log
-- 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;