gcc/testsuite/ada/acats/tests/c4/c46051a.ada

   1 -- C46051A.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 ENUMERATION, RECORD, ACCESS, PRIVATE, AND TASK VALUES CAN
  26 -- BE CONVERTED IF THE OPERAND AND TARGET TYPES ARE RELATED BY
  27 -- DERIVATION.
  28
  29 -- R.WILLIAMS 9/8/86
  30
  31 WITH REPORT; USE REPORT;
  32 PROCEDURE C46051A IS
  33
  34 BEGIN
  35      TEST ( "C46051A", "CHECK THAT ENUMERATION, RECORD, ACCESS, " &
  36                        "PRIVATE, AND TASK VALUES CAN BE CONVERTED " &
  37                        "IF THE OPERAND AND TARGET TYPES ARE " &
  38                        "RELATED BY DERIVATION" );
  39
  40      DECLARE
  41           TYPE ENUM IS (A, AB, ABC, ABCD);
  42           E : ENUM := ABC;
  43
  44           TYPE ENUM1 IS NEW ENUM;
  45           E1 : ENUM1 := ENUM1'VAL (IDENT_INT (2));
  46
  47           TYPE ENUM2 IS NEW ENUM;
  48           E2 : ENUM2 := ABC;
  49
  50           TYPE NENUM1 IS NEW ENUM1;
  51           NE : NENUM1 := NENUM1'VAL (IDENT_INT (2));
  52      BEGIN
  53           IF ENUM (E) /= E THEN
  54                FAILED ( "INCORRECT CONVERSION OF 'ENUM (E)'" );
  55           END IF;
  56
  57           IF ENUM (E1) /= E THEN
  58                FAILED ( "INCORRECT CONVERSION OF 'ENUM (E1)'" );
  59           END IF;
  60
  61           IF ENUM1 (E2) /= E1 THEN
  62                FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E2)'" );
  63           END IF;
  64
  65           IF ENUM2 (NE) /= E2 THEN
  66                FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (NE)'" );
  67           END IF;
  68
  69           IF NENUM1 (E) /= NE THEN
  70                FAILED ( "INCORRECT CONVERSION OF 'NENUM (E)'" );
  71           END IF;
  72      EXCEPTION
  73           WHEN OTHERS =>
  74                FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
  75                         "ENUMERATION TYPES" );
  76      END;
  77
  78      DECLARE
  79           TYPE REC IS
  80                RECORD
  81                     NULL;
  82                END RECORD;
  83
  84           R : REC;
  85
  86           TYPE REC1 IS NEW REC;
  87           R1 : REC1;
  88
  89           TYPE REC2 IS NEW REC;
  90           R2 : REC2;
  91
  92           TYPE NREC1 IS NEW REC1;
  93           NR : NREC1;
  94      BEGIN
  95           IF REC (R) /= R THEN
  96                FAILED ( "INCORRECT CONVERSION OF 'REC (R)'" );
  97           END IF;
  98
  99           IF REC (R1) /= R THEN
 100                FAILED ( "INCORRECT CONVERSION OF 'REC (R1)'" );
 101           END IF;
 102
 103           IF REC1 (R2) /= R1 THEN
 104                FAILED ( "INCORRECT CONVERSION OF 'REC1 (R2)'" );
 105           END IF;
 106
 107           IF REC2 (NR) /= R2 THEN
 108                FAILED ( "INCORRECT CONVERSION OF 'REC2 (NR)'" );
 109           END IF;
 110
 111           IF NREC1 (R) /= NR THEN
 112                FAILED ( "INCORRECT CONVERSION OF 'NREC (R)'" );
 113           END IF;
 114      EXCEPTION
 115           WHEN OTHERS =>
 116                FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
 117                         "RECORD TYPES" );
 118      END;
 119
 120      DECLARE
 121           TYPE REC (D : INTEGER) IS
 122                RECORD
 123                     NULL;
 124                END RECORD;
 125
 126           SUBTYPE CREC IS REC (3);
 127           R : CREC;
 128
 129           TYPE CREC1 IS NEW REC (3);
 130           R1 : CREC1;
 131
 132           TYPE CREC2 IS NEW REC (3);
 133           R2 : CREC2;
 134
 135           TYPE NCREC1 IS NEW CREC1;
 136           NR : NCREC1;
 137      BEGIN
 138           IF CREC (R) /= R THEN
 139                FAILED ( "INCORRECT CONVERSION OF 'CREC (R)'" );
 140           END IF;
 141
 142           IF CREC (R1) /= R THEN
 143                FAILED ( "INCORRECT CONVERSION OF 'CREC (R1)'" );
 144           END IF;
 145
 146           IF CREC1 (R2) /= R1 THEN
 147                FAILED ( "INCORRECT CONVERSION OF 'CREC1 (R2)'" );
 148           END IF;
 149
 150           IF CREC2 (NR) /= R2 THEN
 151                FAILED ( "INCORRECT CONVERSION OF 'CREC2 (NR)'" );
 152           END IF;
 153
 154           IF NCREC1 (R) /= NR THEN
 155                FAILED ( "INCORRECT CONVERSION OF 'NCREC (R)'" );
 156           END IF;
 157      EXCEPTION
 158           WHEN OTHERS =>
 159                FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
 160                         "RECORD TYPES WITH DISCRIMINANTS" );
 161      END;
 162
 163      DECLARE
 164           TYPE REC IS
 165                RECORD
 166                     NULL;
 167                END RECORD;
 168
 169           TYPE ACCREC IS ACCESS REC;
 170           AR : ACCREC;
 171
 172           TYPE ACCREC1 IS NEW ACCREC;
 173           AR1 : ACCREC1;
 174
 175           TYPE ACCREC2 IS NEW ACCREC;
 176           AR2 : ACCREC2;
 177
 178           TYPE NACCREC1 IS NEW ACCREC1;
 179           NAR : NACCREC1;
 180
 181           FUNCTION F (A : ACCREC) RETURN INTEGER IS
 182           BEGIN
 183                RETURN IDENT_INT (0);
 184           END F;
 185
 186           FUNCTION F (A : ACCREC1) RETURN INTEGER IS
 187           BEGIN
 188                RETURN IDENT_INT (1);
 189           END F;
 190
 191           FUNCTION F (A : ACCREC2) RETURN INTEGER IS
 192           BEGIN
 193                RETURN IDENT_INT (2);
 194           END F;
 195
 196           FUNCTION F (A : NACCREC1) RETURN INTEGER IS
 197           BEGIN
 198                RETURN IDENT_INT (3);
 199           END F;
 200
 201      BEGIN
 202           IF F (ACCREC (AR)) /= 0 THEN
 203                FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR)'" );
 204           END IF;
 205
 206           IF F (ACCREC (AR1)) /= 0 THEN
 207                FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR1)'" );
 208           END IF;
 209
 210           IF F (ACCREC1 (AR2)) /= 1 THEN
 211                FAILED ( "INCORRECT CONVERSION OF 'ACCREC1 (AR2)'" );
 212           END IF;
 213
 214           IF F (ACCREC2 (NAR)) /= 2 THEN
 215                FAILED ( "INCORRECT CONVERSION OF 'ACCREC2 (NAR)'" );
 216           END IF;
 217
 218           IF F (NACCREC1 (AR)) /= 3 THEN
 219                FAILED ( "INCORRECT CONVERSION OF 'NACCREC (AR)'" );
 220           END IF;
 221      EXCEPTION
 222           WHEN OTHERS =>
 223                FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
 224                         "ACCESS TYPES" );
 225      END;
 226
 227      DECLARE
 228           TYPE REC (D : INTEGER) IS
 229                RECORD
 230                     NULL;
 231                END RECORD;
 232
 233           TYPE ACCR IS ACCESS REC;
 234
 235           SUBTYPE CACCR IS ACCR (3);
 236           AR : CACCR;
 237
 238           TYPE CACCR1 IS NEW ACCR (3);
 239           AR1 : CACCR1;
 240
 241           TYPE CACCR2 IS NEW ACCR (3);
 242           AR2 : CACCR2;
 243
 244           TYPE NCACCR1 IS NEW CACCR1;
 245           NAR : NCACCR1;
 246
 247           FUNCTION F (A : CACCR) RETURN INTEGER IS
 248           BEGIN
 249                RETURN IDENT_INT (0);
 250           END F;
 251
 252           FUNCTION F (A : CACCR1) RETURN INTEGER IS
 253           BEGIN
 254                RETURN IDENT_INT (1);
 255           END F;
 256
 257           FUNCTION F (A : CACCR2) RETURN INTEGER IS
 258           BEGIN
 259                RETURN IDENT_INT (2);
 260           END F;
 261
 262           FUNCTION F (A : NCACCR1) RETURN INTEGER IS
 263           BEGIN
 264                RETURN IDENT_INT (3);
 265           END F;
 266
 267      BEGIN
 268           IF F (CACCR (AR)) /= 0 THEN
 269                FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR)'" );
 270           END IF;
 271
 272           IF F (CACCR (AR1)) /= 0 THEN
 273                FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR1)'" );
 274           END IF;
 275
 276           IF F (CACCR1 (AR2)) /= 1 THEN
 277                FAILED ( "INCORRECT CONVERSION OF 'CACCR1 (AR2)'" );
 278           END IF;
 279
 280           IF F (CACCR2 (NAR)) /= 2 THEN
 281                FAILED ( "INCORRECT CONVERSION OF 'CACCR2 (NAR)'" );
 282           END IF;
 283
 284           IF F (NCACCR1 (AR)) /= 3 THEN
 285                FAILED ( "INCORRECT CONVERSION OF 'NCACCR (AR)'" );
 286           END IF;
 287      EXCEPTION
 288           WHEN OTHERS =>
 289                FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
 290                         "CONSTRAINED ACCESS TYPES" );
 291      END;
 292
 293      DECLARE
 294           PACKAGE PKG1 IS
 295                TYPE PRIV IS PRIVATE;
 296           PRIVATE
 297                TYPE PRIV IS
 298                     RECORD
 299                          NULL;
 300                     END RECORD;
 301           END PKG1;
 302
 303           USE PKG1;
 304
 305           PACKAGE PKG2 IS
 306                R : PRIV;
 307
 308                TYPE PRIV1 IS NEW PRIV;
 309                R1 : PRIV1;
 310
 311                TYPE PRIV2 IS NEW PRIV;
 312                R2 : PRIV2;
 313           END PKG2;
 314
 315           USE PKG2;
 316
 317           PACKAGE PKG3 IS
 318                TYPE NPRIV1 IS NEW PRIV1;
 319                NR : NPRIV1;
 320           END PKG3;
 321
 322           USE PKG3;
 323      BEGIN
 324           IF PRIV (R) /= R THEN
 325                FAILED ( "INCORRECT CONVERSION OF 'PRIV (R)'" );
 326           END IF;
 327
 328           IF PRIV (R1) /= R THEN
 329                FAILED ( "INCORRECT CONVERSION OF 'PRIV (R1)'" );
 330           END IF;
 331
 332           IF PRIV1 (R2) /= R1 THEN
 333                FAILED ( "INCORRECT CONVERSION OF 'PRIV1 (R2)'" );
 334           END IF;
 335
 336           IF PRIV2 (NR) /= R2 THEN
 337                FAILED ( "INCORRECT CONVERSION OF 'PRIV2 (NR)'" );
 338           END IF;
 339
 340           IF NPRIV1 (R) /= NR THEN
 341                FAILED ( "INCORRECT CONVERSION OF 'NPRIV (R)'" );
 342           END IF;
 343      EXCEPTION
 344           WHEN OTHERS =>
 345                FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
 346                         "PRIVATE TYPES" );
 347      END;
 348
 349      DECLARE
 350           TASK TYPE TK;
 351           T : TK;
 352
 353           TYPE TK1 IS NEW TK;
 354           T1 : TK1;
 355
 356           TYPE TK2 IS NEW TK;
 357           T2 : TK2;
 358
 359           TYPE NTK1 IS NEW TK1;
 360           NT : NTK1;
 361
 362           TASK BODY TK IS
 363           BEGIN
 364                NULL;
 365           END;
 366
 367           FUNCTION F (T : TK) RETURN INTEGER IS
 368           BEGIN
 369                RETURN IDENT_INT (0);
 370           END F;
 371
 372           FUNCTION F (T : TK1) RETURN INTEGER IS
 373           BEGIN
 374                RETURN IDENT_INT (1);
 375           END F;
 376
 377           FUNCTION F (T : TK2) RETURN INTEGER IS
 378           BEGIN
 379                RETURN IDENT_INT (2);
 380           END F;
 381
 382           FUNCTION F (T : NTK1) RETURN INTEGER IS
 383           BEGIN
 384                RETURN IDENT_INT (3);
 385           END F;
 386
 387      BEGIN
 388           IF F (TK (T)) /= 0 THEN
 389                FAILED ( "INCORRECT CONVERSION OF 'TK (T))'" );
 390           END IF;
 391
 392           IF F (TK (T1)) /= 0 THEN
 393                FAILED ( "INCORRECT CONVERSION OF 'TK (T1))'" );
 394           END IF;
 395
 396           IF F (TK1 (T2)) /= 1 THEN
 397                FAILED ( "INCORRECT CONVERSION OF 'TK1 (T2))'" );
 398           END IF;
 399
 400           IF F (TK2 (NT)) /= 2 THEN
 401                FAILED ( "INCORRECT CONVERSION OF 'TK2 (NT))'" );
 402           END IF;
 403
 404           IF F (NTK1 (T)) /= 3 THEN
 405                FAILED ( "INCORRECT CONVERSION OF 'NTK (T))'" );
 406           END IF;
 407      EXCEPTION
 408           WHEN OTHERS =>
 409                FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
 410                         "TASK TYPES" );
 411      END;
 412
 413      RESULT;
 414 END C46051A;