gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c4/c45344a.ada

   1 -- C45344A.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 CORRECT RESULT IS PRODUCED WHEN A FUNCTION RETURNS
  26 -- THE RESULT OF A CATENATION WHOSE BOUNDS ARE NOT DEFINED STATICALLY.
  27
  28 -- R.WILLIAMS 9/1/86
  29
  30 WITH REPORT; USE REPORT;
  31 PROCEDURE C45344A IS
  32
  33 BEGIN
  34      TEST ( "C45344A", "CHECK THAT THE CORRECT RESULT IS PRODUCED " &
  35                        "WHEN A FUNCTION RETURNS THE RESULT OF A " &
  36                        "CATENATION WHOSE BOUNDS ARE NOT DEFINED " &
  37                        "STATICALLY" );
  38
  39      DECLARE
  40           SUBTYPE INT IS INTEGER RANGE IDENT_INT (1) .. IDENT_INT (30);
  41
  42           TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER;
  43           SUBTYPE CARR IS ARR (1 .. 9);
  44           C : CARR;
  45
  46           AR1 : ARR (IDENT_INT (2) .. IDENT_INT (4)) :=
  47                     (IDENT_INT (2) .. IDENT_INT (4) => 1);
  48
  49           AR2 : ARR (IDENT_INT (6) .. IDENT_INT (6)) :=
  50                     (IDENT_INT (6) .. IDENT_INT (6) => 2);
  51
  52           AR3 : ARR (IDENT_INT (4) .. IDENT_INT (2));
  53
  54           FUNCTION F (A, B : ARR; N : NATURAL) RETURN ARR IS
  55           BEGIN
  56                IF N = 0 THEN
  57                     RETURN A & B;
  58                ELSE
  59                     RETURN F (A & B, B, N - 1);
  60                END IF;
  61           END F;
  62
  63           FUNCTION G (A : INTEGER; B : ARR; N : NATURAL) RETURN ARR IS
  64           BEGIN
  65                IF N = 0 THEN
  66                     RETURN A & B;
  67                ELSE
  68                     RETURN G (A, A & B, N - 1);
  69                END IF;
  70           END G;
  71
  72           FUNCTION H (A : ARR; B : INTEGER; N : NATURAL) RETURN ARR IS
  73           BEGIN
  74                IF N = 0 THEN
  75                     RETURN A & B;
  76                ELSE
  77                     RETURN H (A & B, B, N - 1);
  78                END IF;
  79           END H;
  80
  81           PROCEDURE CHECK (X, Y : ARR; F, L : INTEGER; STR : STRING) IS
  82                OK : BOOLEAN := TRUE;
  83           BEGIN
  84                IF X'FIRST /= F AND X'LAST /= L THEN
  85                     FAILED ( "INCORRECT RANGE FOR " & STR);
  86                ELSE
  87                     FOR I IN F .. L LOOP
  88                          IF X (I) /= Y (I) THEN
  89                               OK := FALSE;
  90                          END IF;
  91                     END LOOP;
  92
  93                     IF NOT OK THEN
  94                          FAILED ( "INCORRECT VALUE FOR " & STR);
  95                     END IF;
  96                END IF;
  97           END CHECK;
  98
  99      BEGIN
 100           C := (1 .. 4 => 1, 5 .. 9 => 2);
 101           CHECK (F (AR1, AR2, IDENT_INT (3)), C, 2, 8, "F - 1" );
 102           CHECK (F (AR3, AR2, IDENT_INT (3)), C, 6, 9, "F - 2" );
 103           CHECK (F (AR2, AR3, IDENT_INT (3)), C, 6, 6, "F - 3" );
 104
 105           C := (1 ..4 => 5, 5 .. 9 => 1);
 106           CHECK (G (5, AR1, IDENT_INT (3)), C, 1, 7, "G - 1" );
 107           CHECK (G (5, AR3, IDENT_INT (3)), C, 1, 4, "G - 2" );
 108
 109           CHECK (H (AR3, 5, IDENT_INT (3)), C, 1, 4, "H - 1" );
 110
 111           C := (1 ..4 => 1, 5 .. 9 => 5);
 112           CHECK (H (AR1, 5, IDENT_INT (3)), C, 2, 8, "H - 2" );
 113      END;
 114
 115      RESULT;
 116 END C45344A;