c392010.a

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

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