gcc/testsuite/ada/acats/tests/c5/c52008b.ada

   1 -- C52008B.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 --     CHECK THAT A RECORD VARIABLE DECLARED WITH A SPECIFIED
  27 --     DISCRIMINANT CONSTRAINT CANNOT HAVE A DISCRIMINANT VALUE ALTERED
  28 --     BY ASSIGNMENT.  ASSIGNING AN ENTIRE RECORD VALUE WITH A
  29 --     DIFFERENT DISCRIMINANT VALUE SHOULD RAISE CONSTRAINT_ERROR AND
  30 --     LEAVE THE TARGET VARIABLE UNALTERED.  THIS TEST USES NON-STATIC
  31 --     DISCRIMINANT VALUES.
  32
  33 -- HISTORY:
  34 --     ASL  6/25/81  CREATED ORIGINAL TEST
  35 --     JRK 11/18/82
  36 --     RJW  8/17/89  ADDED SUBTYPE 'SUBINT'.
  37
  38 WITH REPORT;
  39 PROCEDURE C52008B IS
  40
  41      USE REPORT;
  42
  43      TYPE REC1(D1,D2 : INTEGER) IS
  44           RECORD
  45                COMP1 : STRING(D1..D2);
  46           END RECORD;
  47
  48      TYPE AR_REC1 IS ARRAY (NATURAL RANGE <>) OF REC1(IDENT_INT(3),
  49                                                       IDENT_INT(5));
  50
  51      SUBTYPE SUBINT IS INTEGER RANGE -128 .. 127;
  52
  53      TYPE REC2(D1,D2,D3,D4 : SUBINT := 0) IS
  54           RECORD
  55                COMP1 : STRING(1..D1);
  56                COMP2 : STRING(D2..D3);
  57                COMP5 : AR_REC1(1..D4);
  58                COMP6 : REC1(D3,D4);
  59           END RECORD;
  60
  61      STR : STRING(IDENT_INT(3)..IDENT_INT(5)) := "ZZZ";
  62
  63      R1A : REC1(IDENT_INT(3),IDENT_INT(5)) := (3,5,STR);
  64      R1C : REC1(5,6) := (5,6,COMP1 => (5..6 => 'K'));
  65
  66      Q,R : REC2(IDENT_INT(2),IDENT_INT(3),IDENT_INT(5),IDENT_INT(6));
  67      TEMP : REC2(2,3,5,6);
  68
  69      W : REC2(1,4,6,8);
  70      OK : BOOLEAN := FALSE;
  71
  72
  73 BEGIN
  74
  75      TEST ("C52008B", "CANNOT ASSIGN RECORD VARIABLE WITH SPECIFIED " &
  76                       "DISCRIMINANT VALUE A VALUE WITH A DIFFERENT " &
  77                       "(DYNAMIC) DISCRIMINANT VALUE");
  78
  79      BEGIN
  80           R1A := (IDENT_INT(3),5,"XYZ");
  81
  82           R := (IDENT_INT(2),IDENT_INT(3),IDENT_INT(5),IDENT_INT(6),
  83                 "AB",
  84                 STR,
  85                 (1..6 => R1A),
  86                 R1C);
  87
  88           TEMP := R;
  89           Q := TEMP;
  90           R.COMP1 := "YY";
  91           OK := TRUE;
  92           W := R;
  93           FAILED ("ASSIGNMENT MADE USING INCORRECT DISCRIMINANT " &
  94                   "VALUES");
  95      EXCEPTION
  96           WHEN CONSTRAINT_ERROR =>
  97                IF NOT OK
  98                OR Q /= TEMP
  99                OR R = TEMP
 100                OR R = Q
 101                OR W.D4 /= 8 THEN
 102                     FAILED ("LEGITIMATE ASSIGNMENT FAILED");
 103                END IF;
 104           WHEN OTHERS =>
 105                FAILED ("WRONG EXCEPTION");
 106      END;
 107
 108      RESULT;
 109
 110 END C52008B;