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

   1 -- C58005H.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 CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE
  26 -- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER.
  27
  28 -- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH
  29 -- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES.
  30
  31 -- SPS 3/10/83
  32 -- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations.
  33 --               The objects must be used, and must be tied somehow to the
  34 --               calls to Failed.
  35
  36 WITH REPORT;
  37 USE REPORT;
  38 PROCEDURE C58005H IS
  39
  40      PACKAGE PACK IS
  41           TYPE PV (D : NATURAL) IS PRIVATE;
  42           TYPE LP (D : NATURAL) IS LIMITED PRIVATE;
  43      PRIVATE
  44           TYPE PV (D : NATURAL) IS RECORD
  45                NULL;
  46           END RECORD;
  47           TYPE LP (D : NATURAL) IS RECORD
  48                NULL;
  49           END RECORD;
  50      END PACK;
  51
  52      USE PACK;
  53
  54      TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL;
  55      TYPE REC (D : NATURAL) IS RECORD
  56           NULL;
  57      END RECORD;
  58
  59      TYPE ACC_REC IS ACCESS REC;
  60      TYPE ACC_ARR IS ACCESS ARR;
  61      TYPE ACC_PV IS ACCESS PV;
  62      TYPE ACC_LP IS ACCESS LP;
  63
  64      SUBTYPE ACC_REC1 IS ACC_REC (D => 1);
  65      SUBTYPE ACC_REC2 IS ACC_REC (D => 2);
  66
  67      SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10);
  68      SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5);
  69
  70      SUBTYPE ACC_PV1 IS ACC_PV (D => 1);
  71      SUBTYPE ACC_PV2 IS ACC_PV (D => 2);
  72
  73      SUBTYPE ACC_LP1 IS ACC_LP (D => 1);
  74      SUBTYPE ACC_LP2 IS ACC_LP (D => 2);
  75
  76      VAR1 : ACC_REC1 := NEW REC(1);
  77      VAR2 : ACC_REC2 := NEW REC(2);
  78      VAA1 : ACC_ARR1 := NEW ARR(1 .. 10);
  79      VAA2 : ACC_ARR2 := NEW ARR(2 .. 5);
  80      VAP1 : ACC_PV1 := NEW PV(1);
  81      VAP2 : ACC_PV2 := NEW PV(2);
  82      VAL1 : ACC_LP1 := NEW LP(1);
  83      VAL2 : ACC_LP2 := NEW LP(2);
  84
  85      FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS
  86      BEGIN
  87           RETURN X;
  88      END FREC;
  89
  90      FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS
  91      BEGIN
  92           RETURN X;
  93      END FARR;
  94
  95      FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS
  96      BEGIN
  97           RETURN X;
  98      END FPV;
  99
 100      FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS
 101      BEGIN
 102           RETURN X;
 103      END FLP;
 104
 105      PACKAGE BODY PACK IS
 106           FUNCTION LF (X : LP) RETURN INTEGER IS
 107           BEGIN
 108                RETURN IDENT_INT(3);
 109           END LF;
 110      BEGIN
 111           NULL;
 112      END PACK;
 113
 114 BEGIN
 115
 116      TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " &
 117                       "OF FUNCTIONS");
 118
 119      BEGIN
 120           VAR2 := FREC (VAR1);
 121           IF VAR2.D /= REPORT.IDENT_INT(2) THEN
 122               FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1");
 123           ELSE
 124               FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2");
 125           END IF;
 126      EXCEPTION
 127           WHEN CONSTRAINT_ERROR => NULL;
 128           WHEN OTHERS =>
 129                FAILED ("WRONG EXCEPTION RAISED - REC");
 130      END;
 131
 132      BEGIN
 133           VAA2 := FARR (VAA1);
 134           IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN
 135               FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1");
 136           ELSE
 137               FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2");
 138           END IF;
 139      EXCEPTION
 140           WHEN CONSTRAINT_ERROR => NULL;
 141           WHEN OTHERS =>
 142                FAILED ("WRONG EXCEPTION RAISED - ARR");
 143      END;
 144
 145      BEGIN
 146           VAP2 := FPV (VAP1);
 147           IF VAP2.D /= REPORT.IDENT_INT(2) THEN
 148               FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1");
 149           ELSE
 150               FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2");
 151           END IF;
 152      EXCEPTION
 153           WHEN CONSTRAINT_ERROR => NULL;
 154           WHEN OTHERS =>
 155                FAILED ("WRONG EXCEPTION RAISED - PV");
 156      END;
 157
 158      BEGIN
 159           VAL2 := FLP (VAL1);
 160           IF VAL2.D /= REPORT.IDENT_INT(2) THEN
 161               FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1");
 162           ELSE
 163               FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2");
 164           END IF;
 165      EXCEPTION
 166           WHEN CONSTRAINT_ERROR => NULL;
 167           WHEN OTHERS =>
 168                FAILED ("WRONG EXCEPTION RAISED - LP");
 169      END;
 170
 171      RESULT;
 172 END C58005H;