toolchain/gcc/gcc/testsuite/ada/acats/tests/c6/c64109k.ada

   1 -- C64109K.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 -- OBJECTIVE:
  26 --    CHECK THAT SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
  27 --    PASSED CORRECTLY TO SUBPROGRAMS.  SPECIFICALLY,
  28 --    (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS
  29 --       WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS.
  30
  31 -- HISTORY:
  32 --    TBN 07/11/86          CREATED ORIGINAL TEST.
  33 --    JET 08/04/87          MODIFIED REC.A REFERENCES.
  34
  35 WITH REPORT; USE REPORT;
  36 PROCEDURE C64109K IS
  37
  38 BEGIN
  39      TEST ("C64109K", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
  40                       "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
  41                       "TO SUBPROGRAMS - ARRAYS WITH DIFFERENT BOUNDS " &
  42                       "PASSED TO UNCONSTRAINED FORMAL");
  43
  44      DECLARE   -- (E)
  45
  46           SUBTYPE SUBINT IS INTEGER RANGE 0..5;
  47           TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
  48           TYPE RECORD_TYPE IS
  49                RECORD
  50                     A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(4));
  51                     B : ARRAY_TYPE (1..5);
  52                END RECORD;
  53           REC : RECORD_TYPE := (A => (0..4 => IDENT_BOOL(TRUE)),
  54                                 B => (1..5 => IDENT_BOOL(FALSE)));
  55           BOOL : BOOLEAN;
  56
  57           PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS
  58           BEGIN
  59                IF ARR /= (TRUE, TRUE, TRUE) THEN
  60                     FAILED ("IN PARAM NOT PASSED CORRECTLY");
  61                END IF;
  62                IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
  63                     FAILED ("WRONG IN PARAMETER BOUNDS - 1");
  64                END IF;
  65                IF ARR2 /= (FALSE, FALSE, FALSE) THEN
  66                     FAILED ("IN PARAM NOT PASSED CORRECTLY - 2");
  67                END IF;
  68                IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
  69                     FAILED ("WRONG IN PARAMETER BOUNDS - 2");
  70                END IF;
  71           EXCEPTION
  72                WHEN OTHERS =>
  73                     FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
  74           END P1;
  75
  76           FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE)
  77                RETURN BOOLEAN IS
  78           BEGIN
  79                IF ARR /= (TRUE, TRUE, TRUE) THEN
  80                     FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
  81                END IF;
  82                IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
  83                     FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1");
  84                END IF;
  85                IF ARR2 /= (FALSE, FALSE, FALSE) THEN
  86                     FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
  87                END IF;
  88                IF ARR2'FIRST /= 3 OR ARR2'LAST /= IDENT_INT(5) THEN
  89                     FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2");
  90                END IF;
  91                RETURN TRUE;
  92           EXCEPTION
  93                WHEN OTHERS =>
  94                     FAILED ("EXCEPTION RAISED IN FUNCTION F1");
  95           END F1;
  96
  97           PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE;
  98                         ARR2 : IN OUT ARRAY_TYPE) IS
  99           BEGIN
 100                IF ARR /= (TRUE, TRUE, TRUE) THEN
 101                     FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
 102                END IF;
 103                IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN
 104                     FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1");
 105                END IF;
 106                IF ARR2 /= (FALSE, FALSE, FALSE) THEN
 107                     FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
 108                END IF;
 109                IF ARR2'FIRST /= 2 OR ARR2'LAST /= IDENT_INT(4) THEN
 110                     FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2");
 111                END IF;
 112                ARR := (ARR'RANGE => FALSE);
 113                ARR2 := (ARR2'RANGE => TRUE);
 114           EXCEPTION
 115                WHEN OTHERS =>
 116                     FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
 117           END P2;
 118
 119           PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS
 120           BEGIN
 121                IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
 122                     FAILED ("WRONG OUT PARAMETER BOUNDS - 1");
 123                END IF;
 124                IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
 125                     FAILED ("WRONG OUT  PARAMETER BOUNDS - 2");
 126                END IF;
 127                ARR := (ARR'RANGE => FALSE);
 128                ARR2 := (ARR2'RANGE => TRUE);
 129           EXCEPTION
 130                WHEN OTHERS =>
 131                     FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
 132           END P3;
 133
 134      BEGIN     -- (E)
 135
 136           BEGIN     -- (F)
 137                P1 (REC.A (0..2), REC.B (1..3));
 138                IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN
 139                     FAILED ("IN PARAM CHANGED BY PROCEDURE");
 140                END IF;
 141                IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
 142                     FAILED ("IN PARAM CHANGED BY PROCEDURE - 2");
 143                END IF;
 144           EXCEPTION
 145                WHEN OTHERS =>
 146                     FAILED ("EXCEPTION RAISED DURING CALL OF P1");
 147           END;     -- (F)
 148
 149           BEGIN     -- (G)
 150                BOOL := F1 (REC.A (1..3), REC.B (3..5));
 151                IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN
 152                     FAILED ("IN PARAM CHANGED BY FUNCTION");
 153                END IF;
 154                IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
 155                     FAILED ("IN PARAM CHANGED BY FUNCTION - 2");
 156                END IF;
 157           EXCEPTION
 158                WHEN OTHERS =>
 159                     FAILED ("EXCEPTION RAISED DURING CALL OF F1");
 160           END;     -- (G)
 161
 162           BEGIN     -- (H)
 163                P2 (REC.A (2..4), REC.B (2..4));
 164                IF REC.A /= (TRUE, TRUE, FALSE, FALSE, FALSE) THEN
 165                     FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
 166                END IF;
 167                IF REC.B /= (FALSE, TRUE, TRUE, TRUE, FALSE) THEN
 168                     FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2");
 169                END IF;
 170           EXCEPTION
 171                WHEN OTHERS =>
 172                     FAILED ("EXCEPTION RAISED DURING CALL OF P2");
 173           END;     -- (H)
 174
 175           BEGIN     -- (I)
 176                P3 (REC.A (0..2), REC.B (1..3));
 177                IF REC.A /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
 178                     FAILED ("OUT PARAM RETURNED INCORRECTLY");
 179                END IF;
 180                IF REC.B /= (TRUE, TRUE, TRUE, TRUE, FALSE) THEN
 181                     FAILED ("OUT PARAM RETURNED INCORRECTLY - 2");
 182                END IF;
 183           EXCEPTION
 184                WHEN OTHERS =>
 185                     FAILED ("EXCEPTION RAISED DURING CALL OF P3");
 186           END;     -- (I)
 187
 188      END; -- (E)
 189
 190      RESULT;
 191 END C64109K;