c392010.a

来自「用于进行gcc测试」· A 代码 · 共 513 行 · 第 1/2 页

  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;