old-autovect-branch/gcc/testsuite/ada/acats/tests/c4/c47002d.ada

   1 -- C47002D.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 VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS
  26 -- THE OPERANDS OF QUALIFIED EXPRESSIONS.
  27 -- THIS TEST IS FOR PRIVATE AND LIMITED PRIVATE TYPES.
  28
  29 -- RJW 7/23/86
  30
  31 WITH REPORT; USE REPORT;
  32 PROCEDURE C47002D IS
  33
  34 BEGIN
  35
  36      TEST( "C47002D", "CHECK THAT VALUES HAVING PRIVATE AND LIMITED " &
  37                       "PRIVATE TYPES CAN BE WRITTEN AS THE OPERANDS " &
  38                       "OF QUALIFIED EXPRESSIONS" );
  39
  40      DECLARE -- PRIVATE TYPES.
  41
  42           TYPE RESULTS IS (P1, P2, P3, P4, P5);
  43
  44           PACKAGE PKG1 IS
  45                TYPE PINT IS PRIVATE;
  46                TYPE PCHAR IS PRIVATE;
  47                TYPE PARR IS PRIVATE;
  48                TYPE PREC (D : INTEGER) IS PRIVATE;
  49                TYPE PACC IS PRIVATE;
  50
  51                FUNCTION F RETURN PINT;
  52                FUNCTION F RETURN PCHAR;
  53                FUNCTION F RETURN PARR;
  54                FUNCTION F RETURN PREC;
  55                FUNCTION F RETURN PACC;
  56
  57           PRIVATE
  58                TYPE PINT IS NEW INTEGER;
  59                TYPE PCHAR IS NEW CHARACTER;
  60                TYPE PARR IS ARRAY (1 .. 2) OF NATURAL;
  61
  62                TYPE PREC (D : INTEGER) IS
  63                     RECORD
  64                          NULL;
  65                     END RECORD;
  66
  67                TYPE PACC IS ACCESS PREC;
  68
  69           END PKG1;
  70
  71           PACKAGE BODY PKG1 IS
  72                FUNCTION F RETURN PINT IS
  73                BEGIN
  74                     RETURN 1;
  75                END F;
  76
  77                FUNCTION F RETURN PCHAR IS
  78                BEGIN
  79                     RETURN 'B';
  80                END F;
  81
  82                FUNCTION F RETURN PARR IS
  83                BEGIN
  84                     RETURN PARR'(OTHERS => 3);
  85                END F;
  86
  87                FUNCTION F RETURN PREC IS
  88                BEGIN
  89                     RETURN PREC'(D => 4);
  90                END F;
  91
  92                FUNCTION F RETURN PACC IS
  93                BEGIN
  94                     RETURN NEW PREC'(F);
  95                END F;
  96
  97           END PKG1;
  98
  99           PACKAGE PKG2 IS END PKG2;
 100
 101           PACKAGE BODY PKG2 IS
 102                USE PKG1;
 103
 104                FUNCTION CHECK (P : PINT) RETURN RESULTS IS
 105                BEGIN
 106                     RETURN  P1;
 107                END CHECK;
 108
 109                FUNCTION CHECK (P : PCHAR) RETURN RESULTS IS
 110                BEGIN
 111                     RETURN  P2;
 112                END CHECK;
 113
 114                FUNCTION CHECK (P : PARR) RETURN RESULTS IS
 115                BEGIN
 116                     RETURN  P3;
 117                END CHECK;
 118
 119                FUNCTION CHECK (P : PREC) RETURN RESULTS IS
 120                BEGIN
 121                     RETURN  P4;
 122                END CHECK;
 123
 124                FUNCTION CHECK (P : PACC) RETURN RESULTS IS
 125                BEGIN
 126                     RETURN  P5;
 127                END CHECK;
 128
 129           BEGIN
 130                IF CHECK (PINT'(F)) /= P1 THEN
 131                     FAILED ( "INCORRECT RESULTS FOR TYPE PINT" );
 132                END IF;
 133
 134                IF CHECK (PCHAR'(F)) /= P2 THEN
 135                     FAILED ( "INCORRECT RESULTS FOR TYPE PCHAR" );
 136                END IF;
 137
 138                IF CHECK (PARR'(F)) /= P3 THEN
 139                     FAILED ( "INCORRECT RESULTS FOR TYPE PARR" );
 140                END IF;
 141
 142                IF CHECK (PREC'(F)) /= P4 THEN
 143                     FAILED ( "INCORRECT RESULTS FOR TYPE PREC" );
 144                END IF;
 145
 146                IF CHECK (PACC'(F)) /= P5 THEN
 147                     FAILED ( "INCORRECT RESULTS FOR TYPE PACC" );
 148                END IF;
 149
 150           END PKG2;
 151
 152      BEGIN
 153           NULL;
 154      END;
 155
 156      DECLARE -- LIMITED PRIVATE TYPES.
 157
 158           TYPE RESULTS IS (LP1, LP2, LP3, LP4, LP5);
 159
 160           PACKAGE PKG1 IS
 161                TYPE LPINT IS LIMITED PRIVATE;
 162                TYPE LPCHAR IS LIMITED PRIVATE;
 163                TYPE LPARR IS LIMITED PRIVATE;
 164                TYPE LPREC (D : INTEGER) IS LIMITED PRIVATE;
 165                TYPE LPACC IS LIMITED PRIVATE;
 166
 167                FUNCTION F RETURN LPINT;
 168                FUNCTION F RETURN LPCHAR;
 169                FUNCTION F RETURN LPARR;
 170                FUNCTION F RETURN LPREC;
 171                FUNCTION F RETURN LPACC;
 172
 173           PRIVATE
 174                TYPE LPINT IS NEW INTEGER;
 175                TYPE LPCHAR IS NEW CHARACTER;
 176                TYPE LPARR IS ARRAY (1 .. 2) OF NATURAL;
 177
 178                TYPE LPREC (D : INTEGER) IS
 179                     RECORD
 180                          NULL;
 181                     END RECORD;
 182
 183                TYPE LPACC IS ACCESS LPREC;
 184
 185           END PKG1;
 186
 187           PACKAGE BODY PKG1 IS
 188                FUNCTION F RETURN LPINT IS
 189                BEGIN
 190                     RETURN 1;
 191                END F;
 192
 193                FUNCTION F RETURN LPCHAR IS
 194                BEGIN
 195                     RETURN 'B';
 196                END F;
 197
 198                FUNCTION F RETURN LPARR IS
 199                BEGIN
 200                     RETURN LPARR'(OTHERS => 3);
 201                END F;
 202
 203                FUNCTION F RETURN LPREC IS
 204                BEGIN
 205                     RETURN LPREC'(D => 4);
 206                END F;
 207
 208                FUNCTION F RETURN LPACC IS
 209                BEGIN
 210                     RETURN NEW LPREC'(F);
 211                END F;
 212
 213           END PKG1;
 214
 215           PACKAGE PKG2 IS END PKG2;
 216
 217           PACKAGE BODY PKG2 IS
 218                USE PKG1;
 219
 220                FUNCTION CHECK (LP : LPINT) RETURN RESULTS IS
 221                BEGIN
 222                     RETURN  LP1;
 223                END CHECK;
 224
 225                FUNCTION CHECK (LP : LPCHAR) RETURN RESULTS IS
 226                BEGIN
 227                     RETURN  LP2;
 228                END CHECK;
 229
 230                FUNCTION CHECK (LP : LPARR) RETURN RESULTS IS
 231                BEGIN
 232                     RETURN  LP3;
 233                END CHECK;
 234
 235                FUNCTION CHECK (LP : LPREC) RETURN RESULTS IS
 236                BEGIN
 237                     RETURN  LP4;
 238                END CHECK;
 239
 240                FUNCTION CHECK (LP : LPACC) RETURN RESULTS IS
 241                BEGIN
 242                     RETURN  LP5;
 243                END CHECK;
 244
 245           BEGIN
 246                IF CHECK (LPINT'(F)) /= LP1 THEN
 247                     FAILED ( "INCORRECT RESULTS FOR TYPE LPINT" );
 248                END IF;
 249
 250                IF CHECK (LPCHAR'(F)) /= LP2 THEN
 251                     FAILED ( "INCORRECT RESULTS FOR TYPE LPCHAR" );
 252                END IF;
 253
 254                IF CHECK (LPARR'(F)) /= LP3 THEN
 255                     FAILED ( "INCORRECT RESULTS FOR TYPE LPARR" );
 256                END IF;
 257
 258                IF CHECK (LPREC'(F)) /= LP4 THEN
 259                     FAILED ( "INCORRECT RESULTS FOR TYPE LPREC" );
 260                END IF;
 261
 262                IF CHECK (LPACC'(F)) /= LP5 THEN
 263                     FAILED ( "INCORRECT RESULTS FOR TYPE LPACC" );
 264                END IF;
 265
 266           END PKG2;
 267
 268      BEGIN
 269           NULL;
 270      END;
 271
 272      RESULT;
 273 END C47002D;