c74209a.ada

来自「用于进行gcc测试」· ADA 代码 · 共 225 行

-- C74209A.ADA

--                             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.
--*
-- CHECK THAT OUTSIDE A PACKAGE WHICH DEFINES PRIVATE TYPES AND LIMITED
--    PRIVATE TYPES  IT IS POSSIBLE TO DECLARE SUBPROGRAMS WHICH USE
--    THOSE TYPES AS TYPES FOR PARAMETERS (OF ANY MODE EXCEPT OUT FOR A
--    LIMITED TYPE) OR AS THE TYPE FOR THE RESULT (FOR FUNCTION
--    SUBPROGRAMS). 

-- RM 07/14/81


WITH REPORT;
PROCEDURE  C74209A  IS

     USE  REPORT;

BEGIN

     TEST( "C74209A" , "CHECK THAT PROCEDURE SIGNATURES CAN USE " &
                       "PRIVATE TYPES" );

     DECLARE

          PACKAGE  PACK  IS

               TYPE  LIM_PRIV  IS LIMITED PRIVATE;
               TYPE  PRIV      IS         PRIVATE;
               PRIV_CONST_IN   :  CONSTANT  PRIV;
               PRIV_CONST_OUT  :  CONSTANT  PRIV;
               FUNCTION  PACKAGED( X: IN INTEGER )  RETURN LIM_PRIV;
               FUNCTION  EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN ;
               PROCEDURE ASSIGN( X : IN  LIM_PRIV; Y : OUT LIM_PRIV );

          PRIVATE

               TYPE  LIM_PRIV  IS NEW INTEGER;
               TYPE  PRIV      IS NEW STRING( 1..5 );
               PRIV_CONST_IN   :  CONSTANT  PRIV :=  "ABCDE";
               PRIV_CONST_OUT  :  CONSTANT  PRIV :=  "FGHIJ";

          END  PACK;


          PRIV_VAR_1 ,     PRIV_VAR_2      :  PACK.PRIV;
          LIM_PRIV_VAR_1 , LIM_PRIV_VAR_2  :  PACK.LIM_PRIV;


          USE  PACK;


          PACKAGE BODY  PACK  IS

               FUNCTION  PACKAGED( X: IN INTEGER )  RETURN LIM_PRIV  IS
               BEGIN
                    RETURN  LIM_PRIV(X);
               END  PACKAGED;

               FUNCTION  EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN  IS
               BEGIN
                    RETURN  X = Y ;
               END  EQUALS;

               PROCEDURE ASSIGN( X : IN  LIM_PRIV; Y : OUT LIM_PRIV) IS
               BEGIN
                    Y := X;
               END  ASSIGN;

          END  PACK;


          PROCEDURE  PROC1( X : IN OUT PACK.PRIV;
                            Y : IN     PACK.PRIV := PACK.PRIV_CONST_IN;
                            Z : OUT    PACK.PRIV;
                            U :        PACK.PRIV )  IS
          BEGIN

               IF  X /= PACK.PRIV_CONST_IN  OR
                   Y /= PACK.PRIV_CONST_IN  OR
                   U /= PACK.PRIV_CONST_IN
               THEN
                    FAILED( "WRONG INPUT VALUES  -  PROC1" );
               END IF;

               X := PACK.PRIV_CONST_OUT;
               Z := PACK.PRIV_CONST_OUT;

          END  PROC1;


          PROCEDURE  PROC2( X : IN OUT LIM_PRIV;
                            Y : IN     LIM_PRIV;
                            Z : IN OUT LIM_PRIV;
                            U :        LIM_PRIV )  IS
          BEGIN

               IF  NOT(EQUALS( X , PACKAGED(17) ))  OR
                   NOT(EQUALS( Y , PACKAGED(17) ))  OR
                   NOT(EQUALS( U , PACKAGED(17) ))
               THEN
                    FAILED( "WRONG INPUT VALUES  -  PROC2" );
               END IF;

               ASSIGN( PACKAGED(13) , X );
               ASSIGN( PACKAGED(13) , Z );

          END  PROC2;


          FUNCTION  FUNC1( Y : IN  PRIV  :=  PRIV_CONST_IN;
                           U :     PRIV  )   RETURN  PRIV  IS
          BEGIN

               IF  Y /= PRIV_CONST_IN  OR
                   U /= PRIV_CONST_IN
               THEN
                    FAILED( "WRONG INPUT VALUES  -  FUNC1" );
               END IF;

               RETURN  PRIV_CONST_OUT;

          END  FUNC1;


          FUNCTION  FUNC2( Y : IN  LIM_PRIV;
                           U :     LIM_PRIV )  RETURN  LIM_PRIV  IS
          BEGIN

               IF  NOT(EQUALS( Y , PACKAGED(17) ))  OR
                   NOT(EQUALS( U , PACKAGED(17) ))
               THEN
                    FAILED( "WRONG INPUT VALUES  -  FUNC2" );
               END IF;

               RETURN  PACKAGED(13);

          END  FUNC2;


     BEGIN

          --------------------------------------------------------------

          PRIV_VAR_1 := PRIV_CONST_IN;
          PRIV_VAR_2 := PRIV_CONST_IN;

          PROC1( PRIV_VAR_1 , Z => PRIV_VAR_2 , U => PRIV_CONST_IN );

          IF  PRIV_VAR_1 /= PACK.PRIV_CONST_OUT  OR
              PRIV_VAR_2 /= PACK.PRIV_CONST_OUT
          THEN
               FAILED( "WRONG OUTPUT VALUES  -  PROC1" );
          END IF;

          --------------------------------------------------------------

          ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 );
          ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 );

          PROC2( LIM_PRIV_VAR_1 , PACKAGED(17) ,
                 LIM_PRIV_VAR_2 , PACKAGED(17) );

          IF  NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) ))  OR
              NOT(EQUALS( LIM_PRIV_VAR_2 , PACKAGED(13) ))
          THEN
               FAILED( "WRONG OUTPUT VALUES  -  PROC2" );
          END IF;

          --------------------------------------------------------------

          PRIV_VAR_1 := PRIV_CONST_IN;
          PRIV_VAR_2 := PRIV_CONST_IN;

          PRIV_VAR_1 :=
              FUNC1( PRIV_VAR_1 , U => PRIV_CONST_IN );

          IF  PRIV_VAR_1 /= PACK.PRIV_CONST_OUT  
          THEN
               FAILED( "WRONG OUTPUT VALUES  -  FUNC1" );
          END IF;

          --------------------------------------------------------------

          ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 );
          ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 );

          ASSIGN( FUNC2( LIM_PRIV_VAR_1 , PACKAGED(17)) ,
                  LIM_PRIV_VAR_1 );

          IF  NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) ))
          THEN
               FAILED( "WRONG OUTPUT VALUES  -  FUNC2" );
          END IF;

          --------------------------------------------------------------

     END;


     RESULT;


END C74209A;