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

   1 -- C37210A.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 THE EXPRESSION IN A DISCRIMINANT ASSOCIATION WITH MORE
  26 -- THAN ONE NAME IS EVALUATED ONCE FOR EACH NAME.
  27
  28 -- R.WILLIAMS 8/28/86
  29
  30 WITH REPORT; USE REPORT;
  31 PROCEDURE C37210A IS
  32
  33      BUMP : INTEGER := IDENT_INT (0);
  34
  35      FUNCTION F RETURN INTEGER IS
  36      BEGIN
  37           BUMP := BUMP + 1;
  38           RETURN BUMP;
  39      END F;
  40
  41      FUNCTION CHECK (STR : STRING) RETURN INTEGER IS
  42      BEGIN
  43           IF BUMP /= 2 THEN
  44                FAILED ( "INCORRECT DISCRIMINANT VALUES FOR " & STR);
  45           END IF;
  46           BUMP := IDENT_INT (0);
  47           RETURN 5;
  48      END CHECK;
  49
  50 BEGIN
  51      TEST ( "C37210A", "CHECK THAT THE EXPRESSION IN A " &
  52                        "DISCRIMINANT ASSOCIATION WITH MORE THAN " &
  53                        "ONE NAME IS EVALUATED ONCE FOR EACH NAME" );
  54
  55      DECLARE
  56           TYPE REC (D1, D2 : INTEGER) IS
  57                RECORD
  58                     NULL;
  59                END RECORD;
  60
  61           R : REC (D1 | D2 => F);
  62
  63           I1 : INTEGER := CHECK ( "R" );
  64
  65           TYPE ACC IS ACCESS REC;
  66
  67           AC : ACC (D1 | D2 => F);
  68
  69           I2 : INTEGER := CHECK ( "AC" );
  70
  71           PACKAGE PKG IS
  72                TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE;
  73                TYPE PACC IS ACCESS PRIV;
  74
  75                TYPE LIM (D1, D2 : INTEGER) IS LIMITED PRIVATE;
  76                TYPE LACC IS ACCESS LIM;
  77
  78           PRIVATE
  79                TYPE PRIV (D1, D2 : INTEGER) IS
  80                     RECORD
  81                          NULL;
  82                     END RECORD;
  83
  84                TYPE LIM (D1, D2 : INTEGER) IS
  85                     RECORD
  86                          NULL;
  87                     END RECORD;
  88           END PKG;
  89
  90           USE PKG;
  91
  92      BEGIN
  93
  94           DECLARE
  95                P  : PRIV (D1 | D2 => F);
  96
  97                I1 : INTEGER := CHECK ( "P" );
  98
  99                PA : PACC (D1 | D2 => F);
 100
 101                I2 : INTEGER := CHECK ( "PA" );
 102
 103                L  : LIM (D1 | D2 => F);
 104
 105                I3 : INTEGER := CHECK ( "L" );
 106
 107                LA : LACC (D1 | D2 => F);
 108
 109                I : INTEGER;
 110           BEGIN
 111                I := CHECK ( "LA" );
 112           END;
 113      END;
 114
 115      RESULT;
 116 END C37210A;