old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c37209a.ada

   1 -- C37209A.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 CONSTRAINT_ERROR IS NOT RAISED FOR A CONSTANT OBJECT
  26 -- DECLARATION WHOSE SUBTYPE INDICATION SPECIFIES AN UNCONSTRAINED
  27 -- TYPE WITH DEFAULT DISCRIMINANT VALUES AND WHOSE INITIALIZATION
  28 -- EXPRESSION SPECIFIES A VALUE WHOSE DISCRIMINANTS ARE NOT EQUAL TO
  29 -- THE DEFAULT VALUE.
  30
  31 -- R.WILLIAMS 8/25/86
  32
  33 WITH REPORT; USE REPORT;
  34 PROCEDURE C37209A IS
  35
  36 BEGIN
  37      TEST ( "C37209A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
  38                        "FOR A CONSTANT OBJECT DECLARATION WHOSE " &
  39                        "SUBTYPE INDICATION SPECIFIES AN " &
  40                        "UNCONSTRAINED TYPE WITH DEFAULT " &
  41                        "DISCRIMINANT VALUES AND WHOSE " &
  42                        "INITIALIZATION EXPRESSION SPECIFIES A VALUE " &
  43                        "WHOSE DISCRIMINANTS ARE NOT EQUAL TO THE " &
  44                        "DEFAULT VALUE" );
  45      DECLARE
  46
  47           TYPE REC1 (D : INTEGER := IDENT_INT (5)) IS
  48                RECORD
  49                     NULL;
  50                END RECORD;
  51
  52      BEGIN
  53           DECLARE
  54                R1 : CONSTANT REC1 := (D => IDENT_INT (10));
  55           BEGIN
  56                COMMENT ( "NO EXCEPTION RAISED AT DECLARATION OF R1" );
  57           EXCEPTION
  58                WHEN OTHERS =>
  59                     FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" );
  60           END;
  61
  62      EXCEPTION
  63           WHEN CONSTRAINT_ERROR =>
  64                FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " &
  65                         "R1" );
  66           WHEN OTHERS =>
  67                FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " &
  68                         "R1" );
  69      END;
  70
  71
  72      BEGIN
  73           DECLARE
  74                PACKAGE PRIV IS
  75                     TYPE REC2 (D : INTEGER:= IDENT_INT (5)) IS PRIVATE;
  76                     R2 : CONSTANT REC2;
  77
  78                PRIVATE
  79                     TYPE REC2 (D : INTEGER := IDENT_INT (5)) IS
  80                          RECORD
  81                               NULL;
  82                          END RECORD;
  83
  84                     R2 : CONSTANT REC2 := (D => IDENT_INT (10));
  85                END PRIV;
  86
  87                USE PRIV;
  88
  89           BEGIN
  90                DECLARE
  91                     I : INTEGER := R2.D;
  92                BEGIN
  93                     COMMENT ( "NO EXCEPTION RAISED AT DECLARATION " &
  94                               "OF R2" );
  95               END;
  96           END;
  97
  98      EXCEPTION
  99           WHEN CONSTRAINT_ERROR =>
 100                FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " &
 101                          "R2" );
 102           WHEN OTHERS =>
 103                FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
 104                         "OF R2" );
 105      END;
 106
 107      BEGIN
 108           DECLARE
 109                PACKAGE LPRIV IS
 110                     TYPE REC3 (D : INTEGER:= IDENT_INT (5)) IS
 111                          LIMITED PRIVATE;
 112
 113                     R3 : CONSTANT REC3;
 114
 115                PRIVATE
 116                     TYPE REC3 (D : INTEGER := IDENT_INT (5)) IS
 117                          RECORD
 118                               NULL;
 119                          END RECORD;
 120
 121                     R3 : CONSTANT REC3 := (D => IDENT_INT (10));
 122                END LPRIV;
 123
 124                USE LPRIV;
 125
 126           BEGIN
 127                DECLARE
 128                     I : INTEGER;
 129                BEGIN
 130                     I := R3.D;
 131                     COMMENT ( "NO EXCEPTION RAISED AT DECLARATION " &
 132                               "OF R3" );
 133               END;
 134           END;
 135      EXCEPTION
 136           WHEN CONSTRAINT_ERROR =>
 137                FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " &
 138                          "R3" );
 139           WHEN OTHERS =>
 140                FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
 141                         "OF R3" );
 142      END;
 143
 144      RESULT;
 145 END C37209A;