gcc/testsuite/ada/acats/tests/c7/c74209a.ada

   1 -- C74209A.ADA
   2
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 -- CHECK THAT OUTSIDE A PACKAGE WHICH DEFINES PRIVATE TYPES AND LIMITED
  26 --    PRIVATE TYPES  IT IS POSSIBLE TO DECLARE SUBPROGRAMS WHICH USE
  27 --    THOSE TYPES AS TYPES FOR PARAMETERS (OF ANY MODE EXCEPT OUT FOR A
  28 --    LIMITED TYPE) OR AS THE TYPE FOR THE RESULT (FOR FUNCTION
  29 --    SUBPROGRAMS).
  30
  31 -- RM 07/14/81
  32
  33
  34 WITH REPORT;
  35 PROCEDURE  C74209A  IS
  36
  37      USE  REPORT;
  38
  39 BEGIN
  40
  41      TEST( "C74209A" , "CHECK THAT PROCEDURE SIGNATURES CAN USE " &
  42                        "PRIVATE TYPES" );
  43
  44      DECLARE
  45
  46           PACKAGE  PACK  IS
  47
  48                TYPE  LIM_PRIV  IS LIMITED PRIVATE;
  49                TYPE  PRIV      IS         PRIVATE;
  50                PRIV_CONST_IN   :  CONSTANT  PRIV;
  51                PRIV_CONST_OUT  :  CONSTANT  PRIV;
  52                FUNCTION  PACKAGED( X: IN INTEGER )  RETURN LIM_PRIV;
  53                FUNCTION  EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN ;
  54                PROCEDURE ASSIGN( X : IN  LIM_PRIV; Y : OUT LIM_PRIV );
  55
  56           PRIVATE
  57
  58                TYPE  LIM_PRIV  IS NEW INTEGER;
  59                TYPE  PRIV      IS NEW STRING( 1..5 );
  60                PRIV_CONST_IN   :  CONSTANT  PRIV :=  "ABCDE";
  61                PRIV_CONST_OUT  :  CONSTANT  PRIV :=  "FGHIJ";
  62
  63           END  PACK;
  64
  65
  66           PRIV_VAR_1 ,     PRIV_VAR_2      :  PACK.PRIV;
  67           LIM_PRIV_VAR_1 , LIM_PRIV_VAR_2  :  PACK.LIM_PRIV;
  68
  69
  70           USE  PACK;
  71
  72
  73           PACKAGE BODY  PACK  IS
  74
  75                FUNCTION  PACKAGED( X: IN INTEGER )  RETURN LIM_PRIV  IS
  76                BEGIN
  77                     RETURN  LIM_PRIV(X);
  78                END  PACKAGED;
  79
  80                FUNCTION  EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN  IS
  81                BEGIN
  82                     RETURN  X = Y ;
  83                END  EQUALS;
  84
  85                PROCEDURE ASSIGN( X : IN  LIM_PRIV; Y : OUT LIM_PRIV) IS
  86                BEGIN
  87                     Y := X;
  88                END  ASSIGN;
  89
  90           END  PACK;
  91
  92
  93           PROCEDURE  PROC1( X : IN OUT PACK.PRIV;
  94                             Y : IN     PACK.PRIV := PACK.PRIV_CONST_IN;
  95                             Z : OUT    PACK.PRIV;
  96                             U :        PACK.PRIV )  IS
  97           BEGIN
  98
  99                IF  X /= PACK.PRIV_CONST_IN  OR
 100                    Y /= PACK.PRIV_CONST_IN  OR
 101                    U /= PACK.PRIV_CONST_IN
 102                THEN
 103                     FAILED( "WRONG INPUT VALUES  -  PROC1" );
 104                END IF;
 105
 106                X := PACK.PRIV_CONST_OUT;
 107                Z := PACK.PRIV_CONST_OUT;
 108
 109           END  PROC1;
 110
 111
 112           PROCEDURE  PROC2( X : IN OUT LIM_PRIV;
 113                             Y : IN     LIM_PRIV;
 114                             Z : IN OUT LIM_PRIV;
 115                             U :        LIM_PRIV )  IS
 116           BEGIN
 117
 118                IF  NOT(EQUALS( X , PACKAGED(17) ))  OR
 119                    NOT(EQUALS( Y , PACKAGED(17) ))  OR
 120                    NOT(EQUALS( U , PACKAGED(17) ))
 121                THEN
 122                     FAILED( "WRONG INPUT VALUES  -  PROC2" );
 123                END IF;
 124
 125                ASSIGN( PACKAGED(13) , X );
 126                ASSIGN( PACKAGED(13) , Z );
 127
 128           END  PROC2;
 129
 130
 131           FUNCTION  FUNC1( Y : IN  PRIV  :=  PRIV_CONST_IN;
 132                            U :     PRIV  )   RETURN  PRIV  IS
 133           BEGIN
 134
 135                IF  Y /= PRIV_CONST_IN  OR
 136                    U /= PRIV_CONST_IN
 137                THEN
 138                     FAILED( "WRONG INPUT VALUES  -  FUNC1" );
 139                END IF;
 140
 141                RETURN  PRIV_CONST_OUT;
 142
 143           END  FUNC1;
 144
 145
 146           FUNCTION  FUNC2( Y : IN  LIM_PRIV;
 147                            U :     LIM_PRIV )  RETURN  LIM_PRIV  IS
 148           BEGIN
 149
 150                IF  NOT(EQUALS( Y , PACKAGED(17) ))  OR
 151                    NOT(EQUALS( U , PACKAGED(17) ))
 152                THEN
 153                     FAILED( "WRONG INPUT VALUES  -  FUNC2" );
 154                END IF;
 155
 156                RETURN  PACKAGED(13);
 157
 158           END  FUNC2;
 159
 160
 161      BEGIN
 162
 163           --------------------------------------------------------------
 164
 165           PRIV_VAR_1 := PRIV_CONST_IN;
 166           PRIV_VAR_2 := PRIV_CONST_IN;
 167
 168           PROC1( PRIV_VAR_1 , Z => PRIV_VAR_2 , U => PRIV_CONST_IN );
 169
 170           IF  PRIV_VAR_1 /= PACK.PRIV_CONST_OUT  OR
 171               PRIV_VAR_2 /= PACK.PRIV_CONST_OUT
 172           THEN
 173                FAILED( "WRONG OUTPUT VALUES  -  PROC1" );
 174           END IF;
 175
 176           --------------------------------------------------------------
 177
 178           ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 );
 179           ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 );
 180
 181           PROC2( LIM_PRIV_VAR_1 , PACKAGED(17) ,
 182                  LIM_PRIV_VAR_2 , PACKAGED(17) );
 183
 184           IF  NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) ))  OR
 185               NOT(EQUALS( LIM_PRIV_VAR_2 , PACKAGED(13) ))
 186           THEN
 187                FAILED( "WRONG OUTPUT VALUES  -  PROC2" );
 188           END IF;
 189
 190           --------------------------------------------------------------
 191
 192           PRIV_VAR_1 := PRIV_CONST_IN;
 193           PRIV_VAR_2 := PRIV_CONST_IN;
 194
 195           PRIV_VAR_1 :=
 196               FUNC1( PRIV_VAR_1 , U => PRIV_CONST_IN );
 197
 198           IF  PRIV_VAR_1 /= PACK.PRIV_CONST_OUT
 199           THEN
 200                FAILED( "WRONG OUTPUT VALUES  -  FUNC1" );
 201           END IF;
 202
 203           --------------------------------------------------------------
 204
 205           ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 );
 206           ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 );
 207
 208           ASSIGN( FUNC2( LIM_PRIV_VAR_1 , PACKAGED(17)) ,
 209                   LIM_PRIV_VAR_1 );
 210
 211           IF  NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) ))
 212           THEN
 213                FAILED( "WRONG OUTPUT VALUES  -  FUNC2" );
 214           END IF;
 215
 216           --------------------------------------------------------------
 217
 218      END;
 219
 220
 221      RESULT;
 222
 223
 224 END C74209A;