Subversion Repositories openrisc_me

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