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

   1 -- C47008A.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 -- OBJECTIVE:
  26 --     WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A
  27 --     CONSTRAINED RECORD, PRIVATE, OR LIMITED PRIVATE TYPE, CHECK THAT
  28 --     CONSTRAINT_ERROR IS RAISED WHEN THE DISCRIMINANTS OF THE OPERAND
  29 --     DO NOT EQUAL THOSE OF THE TYPE MARK.
  30
  31 -- HISTORY:
  32 --     RJW 07/23/86
  33 --     DWC 07/24/87  CHANGED CODE TO TEST FOR FIRST DISCRIMINANT
  34 --                   AND LAST DISCRIMINANT MISMATCH.
  35
  36 WITH REPORT; USE REPORT;
  37 PROCEDURE C47008A IS
  38
  39      TYPE GENDER IS (MALE, FEMALE, NEUTER);
  40
  41      FUNCTION IDENT (G : GENDER) RETURN GENDER IS
  42      BEGIN
  43           RETURN GENDER'VAL (IDENT_INT (GENDER'POS (G)));
  44      END IDENT;
  45
  46 BEGIN
  47
  48      TEST( "C47008A", "WHEN THE TYPE MARK IN A QUALIFIED " &
  49                       "EXPRESSION DENOTES A CONSTRAINED RECORD, " &
  50                       "PRIVATE, OR LIMITED PRIVATE TYPE, CHECK " &
  51                       "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " &
  52                       "DISCRIMANTS OF THE OPERAND DO NOT EQUAL " &
  53                       "THOSE OF THE TYPE MARK" );
  54
  55      DECLARE
  56
  57           TYPE PERSON (SEX : GENDER) IS
  58                RECORD
  59                     NULL;
  60                END RECORD;
  61
  62           SUBTYPE WOMAN IS PERSON (IDENT (FEMALE));
  63           TOM : PERSON (MALE) := (SEX => IDENT (MALE));
  64
  65      BEGIN
  66           IF WOMAN'(TOM) = PERSON'(SEX => MALE) THEN
  67                FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
  68                         "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 1");
  69           ELSE
  70                FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
  71                         "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 2");
  72           END IF;
  73      EXCEPTION
  74           WHEN CONSTRAINT_ERROR =>
  75                NULL;
  76           WHEN OTHERS =>
  77                FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " &
  78                         "DISC NOT EQUAL TO THOSE OF SUBTYPE WOMAN" );
  79      END;
  80
  81      DECLARE
  82           TYPE PAIR (SEX1, SEX2 : GENDER) IS
  83                RECORD
  84                     NULL;
  85                END RECORD;
  86
  87           SUBTYPE COUPLE IS PAIR (IDENT (FEMALE), IDENT (MALE));
  88           JONESES : PAIR (IDENT (MALE), IDENT (FEMALE));
  89
  90      BEGIN
  91           IF COUPLE'(JONESES) = PAIR'(SEX1 => MALE, SEX2 => FEMALE)
  92              THEN
  93                FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
  94                         "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 1");
  95           ELSE
  96                FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
  97                         "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 2");
  98           END IF;
  99      EXCEPTION
 100           WHEN CONSTRAINT_ERROR =>
 101                NULL;
 102           WHEN OTHERS =>
 103                FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " &
 104                         "DISC NOT EQUAL TO THOSE OF SUBTYPE COUPLE" );
 105      END;
 106
 107      DECLARE
 108
 109           PACKAGE PKG IS
 110                TYPE PERSON (SEX : GENDER) IS PRIVATE;
 111                SUBTYPE MAN IS PERSON (IDENT (MALE));
 112
 113                TESTWRITER : CONSTANT PERSON;
 114
 115           PRIVATE
 116                TYPE PERSON (SEX : GENDER) IS
 117                     RECORD
 118                          NULL;
 119                     END RECORD;
 120
 121                TESTWRITER : CONSTANT PERSON := (SEX => FEMALE);
 122
 123           END PKG;
 124
 125           USE PKG;
 126
 127           ROSA : PERSON (IDENT (FEMALE));
 128
 129      BEGIN
 130           IF MAN'(ROSA) = TESTWRITER THEN
 131                FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
 132                         "NOT EQUAL TO THOSE OF SUBTYPE MAN - 1" );
 133           ELSE
 134                FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
 135                         "NOT EQUAL TO THOSE OF SUBTYPE MAN - 2" );
 136           END IF;
 137      EXCEPTION
 138           WHEN CONSTRAINT_ERROR =>
 139                NULL;
 140           WHEN OTHERS =>
 141                FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " &
 142                         "DISC NOT EQUAL TO THOSE OF SUBTYPE MAN" );
 143      END;
 144
 145      DECLARE
 146           PACKAGE PKG IS
 147                TYPE PAIR (SEX1, SEX2 : GENDER) IS PRIVATE;
 148                SUBTYPE FRIENDS IS PAIR (IDENT (FEMALE), IDENT (MALE));
 149
 150                ALICE_AND_JERRY : CONSTANT FRIENDS;
 151
 152           PRIVATE
 153                TYPE PAIR (SEX1, SEX2 : GENDER) IS
 154                     RECORD
 155                          NULL;
 156                     END RECORD;
 157
 158                ALICE_AND_JERRY : CONSTANT FRIENDS :=
 159                                  (IDENT (FEMALE), IDENT (MALE));
 160
 161           END PKG;
 162
 163           USE PKG;
 164
 165           DICK_AND_JOE : PAIR (IDENT (MALE), IDENT (MALE));
 166
 167      BEGIN
 168           IF FRIENDS'(DICK_AND_JOE) = ALICE_AND_JERRY THEN
 169                FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
 170                         "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 1");
 171           ELSE
 172                FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
 173                         "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 2");
 174           END IF;
 175      EXCEPTION
 176           WHEN CONSTRAINT_ERROR =>
 177                NULL;
 178           WHEN OTHERS =>
 179                FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " &
 180                         "DISC NOT EQUAL TO THOSE OF SUBTYPE FRIENDS" );
 181      END;
 182
 183      DECLARE
 184
 185           PACKAGE PKG1 IS
 186                TYPE PERSON (SEX : GENDER) IS LIMITED PRIVATE;
 187                SUBTYPE ANDROID IS PERSON (IDENT (NEUTER));
 188
 189                FUNCTION F RETURN PERSON;
 190                FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN;
 191           PRIVATE
 192                TYPE PERSON (SEX : GENDER) IS
 193                     RECORD
 194                          NULL;
 195                     END RECORD;
 196
 197           END PKG1;
 198
 199           PACKAGE BODY PKG1 IS
 200
 201                FUNCTION F RETURN PERSON IS
 202                BEGIN
 203                     RETURN PERSON'(SEX => (IDENT (MALE)));
 204                END F;
 205
 206                FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN IS
 207                BEGIN
 208                     RETURN A.SEX = B.SEX;
 209                END;
 210
 211           END PKG1;
 212
 213           PACKAGE PKG2 IS END PKG2;
 214
 215           PACKAGE BODY PKG2 IS
 216                USE PKG1;
 217
 218           BEGIN
 219                IF ANDROID'(F) = F THEN
 220                     FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " &
 221                              "DISC NOT EQUAL TO THOSE OF SUBTYPE " &
 222                              "ANDROID - 1");
 223                ELSE
 224                     FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " &
 225                              "DISC NOT EQUAL TO THOSE OF SUBTYPE " &
 226                              "ANDROID - 2");
 227                END IF;
 228           EXCEPTION
 229                WHEN CONSTRAINT_ERROR =>
 230                     NULL;
 231                WHEN OTHERS =>
 232                     FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " &
 233                              "WITH DISC NOT EQUAL TO THOSE OF " &
 234                              "SUBTYPE ANDROID" );
 235           END PKG2;
 236
 237      BEGIN
 238           NULL;
 239      END;
 240
 241      DECLARE
 242           PACKAGE PKG1 IS
 243                TYPE PAIR (SEX1, SEX2 : GENDER) IS LIMITED PRIVATE;
 244                SUBTYPE LOVERS IS PAIR (IDENT (FEMALE), IDENT (MALE));
 245
 246                FUNCTION F RETURN PAIR;
 247                FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN;
 248           PRIVATE
 249                TYPE PAIR (SEX1, SEX2 : GENDER) IS
 250                     RECORD
 251                          NULL;
 252                     END RECORD;
 253           END PKG1;
 254
 255           PACKAGE BODY PKG1 IS
 256
 257                FUNCTION F RETURN PAIR IS
 258                BEGIN
 259                     RETURN PAIR'(SEX1 => (IDENT (FEMALE)),
 260                                    SEX2 => (IDENT (FEMALE)));
 261                END F;
 262
 263                FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN IS
 264                BEGIN
 265                     RETURN A.SEX1 = B.SEX2;
 266                END;
 267
 268           END PKG1;
 269
 270           PACKAGE PKG2 IS END PKG2;
 271
 272           PACKAGE BODY PKG2 IS
 273                USE PKG1;
 274
 275           BEGIN
 276                IF LOVERS'(F) = F THEN
 277                     FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " &
 278                              "DISC NOT EQUAL TO THOSE OF SUBTYPE " &
 279                              "LOVERS - 1");
 280                ELSE
 281                     FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " &
 282                              "DISC NOT EQUAL TO THOSE OF SUBTYPE " &
 283                              "LOVERS - 2");
 284                END IF;
 285           EXCEPTION
 286                WHEN CONSTRAINT_ERROR =>
 287                     NULL;
 288                WHEN OTHERS =>
 289                     FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " &
 290                              "WITH DISC NOT EQUAL TO THOSE OF " &
 291                              "SUBTYPE LOVERS" );
 292           END PKG2;
 293
 294      BEGIN
 295           NULL;
 296      END;
 297
 298      RESULT;
 299 END C47008A;