gcc/testsuite/ada/acats/tests/c3/c37310a.ada

   1 -- C37310A.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 IF A DISCRIMINANT HAS A DYNAMIC SUBTYPE, AN OTHERS
  26 -- CHOICE CAN BE OMITTED IF ALL VALUES IN THE BASE
  27 -- TYPE'S RANGE ARE COVERED.
  28
  29 -- ASL 7/10/81
  30 -- SPS 10/25/82
  31 -- PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  32
  33 WITH REPORT;
  34 PROCEDURE C37310A IS
  35
  36      USE REPORT;
  37
  38 BEGIN
  39      TEST ("C37310A", "CHECK DYNAMIC DISCRIMINANT SUBTYPES " &
  40                       "IN VARIANT RECORD DECLARATIONS");
  41
  42      DECLARE
  43
  44           ACHAR : CHARACTER := IDENT_CHAR('A');
  45           ECHAR : CHARACTER := IDENT_CHAR('E');
  46           JCHAR : CHARACTER := IDENT_CHAR('J');
  47           MCHAR : CHARACTER := IDENT_CHAR('M');
  48           SUBTYPE STATCHAR IS CHARACTER RANGE 'I'..'N';
  49           SUBTYPE DYNCHAR IS CHARACTER RANGE ACHAR..ECHAR;
  50           SUBTYPE SSTAT IS STATCHAR RANGE JCHAR..MCHAR;
  51
  52           TYPE LETTER IS NEW CHARACTER RANGE 'A'..'Z';
  53           SUBTYPE DYNLETTER IS
  54                LETTER RANGE LETTER(ECHAR)..LETTER(JCHAR);
  55
  56           TYPE REC1(DISC : SSTAT := 'K') IS
  57                RECORD
  58                     CASE DISC IS
  59                          WHEN ASCII.NUL..CHARACTER'LAST => NULL;
  60                     END CASE;
  61                END RECORD;
  62
  63           TYPE REC2(DISC : DYNCHAR := 'C') IS
  64                RECORD
  65                     CASE DISC IS
  66                          WHEN ASCII.NUL..CHARACTER'LAST => NULL;
  67                     END CASE;
  68                END RECORD;
  69
  70           TYPE REC3(DISC: DYNCHAR := 'D') IS
  71                RECORD
  72                     CASE DISC IS
  73                          WHEN CHARACTER'FIRST..CHARACTER'LAST => NULL;
  74                     END CASE;
  75                END RECORD;
  76
  77           TYPE REC4(DISC : DYNLETTER := 'F') IS
  78                RECORD
  79                     CASE DISC IS
  80                          WHEN LETTER'BASE'FIRST..
  81                               LETTER'BASE'LAST => NULL;
  82                     END CASE;
  83                END RECORD;
  84
  85           R1 : REC1;
  86           R2 : REC2;
  87           R3 : REC3;
  88           R4 : REC4;
  89      BEGIN
  90           IF EQUAL(3,3) THEN
  91                R1 := (DISC => 'L');
  92           END IF;
  93           IF R1.DISC /= 'L' THEN
  94                FAILED ("ASSIGNMENT FAILED - 1");
  95           END IF;
  96
  97           IF EQUAL(3,3) THEN
  98               R2 := (DISC => 'B');
  99           END IF;
 100           IF R2.DISC /= 'B' THEN
 101                FAILED ("ASSIGNMENT FAILED - 2");
 102           END IF;
 103
 104           IF EQUAL(3,3) THEN
 105                R3 := (DISC => 'B');
 106           END IF;
 107           IF R3.DISC /= 'B' THEN
 108                FAILED ("ASSIGNMENT FAILED - 3");
 109           END IF;
 110
 111           IF EQUAL(3,3) THEN
 112                R4 := (DISC => 'H');
 113           END IF;
 114           IF R4.DISC /= 'H' THEN
 115                FAILED ("ASSIGNMENT FAILED - 4");
 116           END IF;
 117      EXCEPTION
 118           WHEN OTHERS =>
 119               FAILED ("EXCEPTION RAISED");
 120      END;
 121
 122      RESULT;
 123
 124 END C37310A;