old-autovect-branch/gcc/testsuite/ada/acats/tests/c5/c52011b.ada

   1 -- C52011B.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 DISCRIMINANT CONSTRAINTS FOR ASSIGNMENT OF ACCESS SUBTYPES.
  26 -- SPECIFICALLY, CHECK THAT:
  27
  28 -- A) ANY ACCESS TYPE VARIABLE AND CONSTRAINED SUBTYPE VARIABLES OF THAT
  29 -- TYPE MAY BE ASSIGNED TO ONE ANOTHER IF THE VALUE BEING ASSIGNED
  30 -- IS NULL.
  31
  32 -- B) VARIABLES OF THE SAME CONSTRAINED ACCESS SUBTYPE MAY BE ASSIGNED
  33 -- TO ONE ANOTHER OR TO VARIABLES OF THE BASE ACCESS TYPE.
  34
  35 -- C) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF NON-NULL OBJECTS
  36 -- BETWEEN DIFFERENTLY CONSTRAINED ACCESS SUBTYPES.
  37
  38 -- D) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF A NON-NULL OBJECT
  39 -- OF A BASE ACCESS TYPE VARIABLE TO A VARIABLE OF ONE OF ITS
  40 -- CONSTRAINED SUBTYPES IF THE CONSTRAINTS ON THE OBJECT DIFFER
  41 -- FROM THOSE ON THE SUBTYPE.
  42
  43 -- E) NULL CAN BE ASSIGNED TO BASE ACCESS TYPES AND ANY CONSTRAINED
  44 -- SUBTYPES OF THIS TYPE.
  45
  46 -- ASL 7/06/81
  47 --  RM 6/17/82
  48 -- RLB 6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION.
  49
  50 WITH REPORT;
  51 PROCEDURE C52011B IS
  52
  53      USE REPORT;
  54
  55      TYPE REC(DISC : INTEGER := -1 ) IS
  56           RECORD
  57                NULL;
  58           END RECORD;
  59
  60      TYPE REC_NAME IS ACCESS REC;
  61      SUBTYPE S1 IS REC_NAME(IDENT_INT(5));
  62      SUBTYPE S2 IS REC_NAME(IDENT_INT(3));
  63
  64      W : REC_NAME := NULL;                    -- E.
  65      X1,X2 : S1 := NULL;                      -- E.
  66      Y1,Y2 : S2 := NULL;                      -- E.
  67
  68      W_NONNULL  : REC_NAME := NEW REC(7) ;
  69      X1_NONNULL : S1       := NEW REC(IDENT_INT(5));
  70      Y1_NONNULL : S2       := NEW REC(IDENT_INT(3));
  71
  72      TOO_EARLY : BOOLEAN := TRUE;
  73
  74 BEGIN
  75
  76      TEST ("C52011B", "DISCRIMINANT CONSTRAINTS ON ACCESS SUBTYPE " &
  77                       "OBJECTS MUST BE SATISFIED FOR ASSIGNMENT");
  78
  79      BEGIN
  80
  81           IF EQUAL(3,3) THEN
  82                W_NONNULL := X1;               -- A.
  83           END IF;
  84           IF W_NONNULL /= X1 THEN
  85                FAILED ("ASSIGNMENT FAILED - 1");
  86           END IF;
  87
  88           IF EQUAL(3,3) THEN
  89                W := Y1;                       -- A.
  90           END IF;
  91           IF W /= Y1 THEN
  92                FAILED ("ASSIGNMENT FAILED - 2");
  93           END IF;
  94
  95           IF EQUAL(3,3) THEN
  96                X1_NONNULL := Y1;              -- A.
  97           END IF;
  98           IF X1_NONNULL /= Y1 THEN
  99                FAILED ("ASSIGNMENT FAILED - 3");
 100           END IF;
 101
 102           IF EQUAL(3,3) THEN
 103                Y1_NONNULL := Y2;              -- A.
 104           END IF;
 105           IF Y1_NONNULL /= Y2 THEN
 106                FAILED ("ASSIGNMENT FAILED - 4");
 107           END IF;
 108
 109           X1 := NEW REC(IDENT_INT(5));
 110           IF EQUAL(3,3) THEN
 111                X2 := X1;                      -- B.
 112           END IF;
 113           IF X1 /= X2 THEN
 114                FAILED ("ASSIGNMENT FAILED - 5");
 115           END IF;
 116
 117           IF EQUAL(3,3) THEN
 118                W := X1;                       -- B.
 119           END IF;
 120           IF W /= X1 THEN
 121                FAILED ("ASSIGNMENT FAILED - 6");
 122           END IF;
 123
 124           BEGIN
 125                Y1 := X1;                      -- C.
 126                IF Y1.DISC /= REPORT.IDENT_INT(3) THEN
 127                   FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
 128                      "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
 129                      "AND CONSTRAINT IS CHANGED");
 130                ELSE
 131                   FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
 132                      "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
 133                      "AND CONSTRAINT IS NOT CHANGED");
 134                END IF;
 135           EXCEPTION
 136
 137                WHEN CONSTRAINT_ERROR => NULL;
 138
 139                WHEN OTHERS =>
 140                     FAILED ("WRONG EXCEPTION - 1");
 141
 142           END;
 143
 144           W := NEW REC(IDENT_INT(3));
 145
 146           BEGIN
 147                X1 := W;                            -- D.
 148                IF X1.DISC /= REPORT.IDENT_INT(5) THEN
 149                   FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
 150                           "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
 151                           "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
 152                           "AND CONSTRAINT IS CHANGED");
 153                ELSE
 154                   FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
 155                           "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
 156                           "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
 157                           "AND CONSTRAINT IS NOT CHANGED");
 158                END IF;
 159           EXCEPTION
 160
 161                WHEN CONSTRAINT_ERROR =>
 162                     NULL ;
 163
 164                WHEN OTHERS =>
 165                     FAILED ("WRONG EXCEPTION - 2");
 166
 167           END;
 168
 169      EXCEPTION
 170
 171           WHEN OTHERS =>
 172                FAILED ("EXCEPTION RAISED");
 173
 174      END;
 175
 176
 177      RESULT;
 178
 179
 180 END C52011B;