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

   1 -- C48009H.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 -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
  26 -- IS RAISED IF T IS AN (UNCONSTRAINED) ACCESS TYPE, THE DESIGNATED TYPE
  27 -- FOR T'BASE IS CONSTRAINED, AND THE OBJECT DESIGNATED BY X DOES NOT
  28 -- HAVE DISCRIMINANTS OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING
  29 -- VALUES FOR T'S DESIGNATED TYPE.
  30
  31 -- EG  08/30/84
  32
  33 WITH REPORT;
  34
  35 PROCEDURE C48009H IS
  36
  37      USE REPORT;
  38
  39 BEGIN
  40
  41      TEST("C48009H","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
  42                     "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
  43                     "APPROPRIATE - UNCONSTRAINED ACCESS TYPE OF A " &
  44                     "CONSTRAINED TYPE");
  45
  46      DECLARE
  47
  48           TYPE UR(A : INTEGER) IS
  49                RECORD
  50                     NULL;
  51                END RECORD;
  52           TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
  53
  54           PACKAGE P IS
  55                TYPE UP(A : INTEGER) IS PRIVATE;
  56                TYPE UL(A : INTEGER) IS LIMITED PRIVATE;
  57           PRIVATE
  58                TYPE UP(A : INTEGER) IS
  59                     RECORD
  60                          NULL;
  61                     END RECORD;
  62                TYPE UL(A : INTEGER) IS
  63                     RECORD
  64                          NULL;
  65                     END RECORD;
  66           END P;
  67
  68           TYPE A_CR IS ACCESS UR(IDENT_INT(2));
  69           TYPE A_CA IS ACCESS UA(2 .. IDENT_INT(4));
  70           TYPE A_CP IS ACCESS P.UP(3);
  71           TYPE A_CL IS ACCESS P.UL(4);
  72
  73           TYPE AA_CR IS ACCESS A_CR;
  74           TYPE AA_CA IS ACCESS A_CA;
  75           TYPE AA_CP IS ACCESS A_CP;
  76           TYPE AA_CL IS ACCESS A_CL;
  77
  78           V_AA_CR : AA_CR;
  79           V_AA_CA : AA_CA;
  80           V_AA_CP : AA_CP;
  81           V_AA_CL : AA_CL;
  82
  83      BEGIN
  84
  85           BEGIN
  86                V_AA_CR := NEW A_CR'(NEW UR(3));
  87                FAILED ("NO EXCEPTION RAISED - CR");
  88           EXCEPTION
  89                WHEN CONSTRAINT_ERROR =>
  90                     NULL;
  91                WHEN OTHERS =>
  92                     FAILED ("WRONG EXCEPTION RAISED - CR");
  93           END;
  94
  95           BEGIN
  96                V_AA_CA := NEW A_CA'(NEW UA(IDENT_INT(3) .. 5));
  97                FAILED ("NO EXCEPTION RAISED - CA");
  98           EXCEPTION
  99                WHEN CONSTRAINT_ERROR =>
 100                     NULL;
 101                WHEN OTHERS =>
 102                     FAILED ("WRONG EXCEPTION RAISED - CA");
 103           END;
 104
 105           BEGIN
 106                V_AA_CP := NEW A_CP'(NEW P.UP(IDENT_INT(4)));
 107                FAILED ("NO EXCEPTION RAISED - CP");
 108           EXCEPTION
 109                WHEN CONSTRAINT_ERROR =>
 110                     NULL;
 111                WHEN OTHERS =>
 112                     FAILED ("WRONG EXCEPTION RAISED - CP");
 113           END;
 114
 115           BEGIN
 116                V_AA_CL := NEW A_CL'(NEW P.UL(5));
 117                FAILED ("NO EXCEPTION RAISED - CL");
 118           EXCEPTION
 119                WHEN CONSTRAINT_ERROR =>
 120                     NULL;
 121                WHEN OTHERS =>
 122                     FAILED ("WRONG EXCEPTION RAISED - CL");
 123           END;
 124
 125      END;
 126
 127      RESULT;
 128
 129 END C48009H;