old-autovect-branch/gcc/testsuite/ada/acats/tests/c6/c64109h.ada

   1 -- C64109H.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 --       (A) CHECK ALL PARAMETER MODES.
  29
  30 -- HISTORY:
  31 --    TBN 07/11/86          CREATED ORIGINAL TEST.
  32 --    JET 08/04/87          MODIFIED REC.A REFERENCES.
  33
  34 WITH REPORT; USE REPORT;
  35 PROCEDURE C64109H IS
  36
  37 BEGIN
  38      TEST ("C64109H", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
  39                       "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
  40                       "TO SUBPROGRAMS");
  41
  42      DECLARE   -- (A)
  43
  44           TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
  45           SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5));
  46           TYPE RECORD_TYPE IS
  47                RECORD
  48                     I : INTEGER;
  49                     A : ARRAY_SUBTYPE;
  50                END RECORD;
  51           REC : RECORD_TYPE := (I => 23,
  52                                 A => (1..3 => IDENT_INT(7), 4..5 => 9));
  53           BOOL : BOOLEAN;
  54
  55           PROCEDURE P1 (ARR : ARRAY_TYPE) IS
  56           BEGIN
  57                IF ARR /= (7, 9, 9) THEN
  58                     FAILED ("IN PARAMETER NOT PASSED CORRECTLY");
  59                END IF;
  60
  61                IF ARR'FIRST /= IDENT_INT(3) OR
  62                   ARR'LAST /= IDENT_INT(5) THEN
  63                     FAILED ("WRONG BOUNDS FOR IN PARAMETER");
  64                END IF;
  65           EXCEPTION
  66                WHEN OTHERS =>
  67                     FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
  68           END P1;
  69
  70           FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
  71           BEGIN
  72                IF ARR /= (7, 7, 9) THEN
  73                     FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN");
  74                END IF;
  75                IF ARR'FIRST /= IDENT_INT(2) OR
  76                   ARR'LAST /= IDENT_INT(4) THEN
  77                     FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN");
  78                END IF;
  79
  80                RETURN TRUE;
  81           EXCEPTION
  82                WHEN OTHERS =>
  83                     FAILED ("EXCEPTION RAISED IN FUNCTION F1");
  84           END F1;
  85
  86           PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
  87           BEGIN
  88                IF ARR /= (7, 7, 7, 9) THEN
  89                     FAILED ("IN OUT PARAMETER NOT PASSED " &
  90                             "CORRECTLY");
  91                END IF;
  92                IF ARR'FIRST /= IDENT_INT(1) OR
  93                   ARR'LAST /= IDENT_INT(4) THEN
  94                     FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER");
  95                END IF;
  96                ARR := (ARR'RANGE => 5);
  97           EXCEPTION
  98                WHEN OTHERS =>
  99                     FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
 100           END P2;
 101
 102           PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
 103           BEGIN
 104                IF ARR'FIRST /= IDENT_INT(3) OR
 105                   ARR'LAST /= IDENT_INT(4) THEN
 106                     FAILED ("WRONG BOUNDS FOR OUT PARAMETER");
 107                END IF;
 108
 109                ARR := (ARR'RANGE => 3);
 110           EXCEPTION
 111                WHEN OTHERS =>
 112                     FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
 113           END P3;
 114
 115      BEGIN     -- (A)
 116
 117           BEGIN     -- (B)
 118                P1 (REC.A (3..5));
 119                IF REC.A /= (7, 7, 7, 9, 9) THEN
 120                     FAILED ("IN PARAM CHANGED BY PROCEDURE");
 121                END IF;
 122           EXCEPTION
 123                WHEN OTHERS =>
 124                     FAILED ("EXCEPTION RAISED DURING CALL OF P1");
 125           END;     -- (B)
 126
 127           BEGIN     -- (C)
 128                BOOL := F1 (REC.A (2..4));
 129                IF REC.A /= (7, 7, 7, 9, 9) THEN
 130                     FAILED ("IN PARAM CHANGED BY FUNCTION");
 131                END IF;
 132           EXCEPTION
 133                WHEN OTHERS =>
 134                     FAILED ("EXCEPTION RAISED DURING CALL OF F1");
 135           END;     -- (C)
 136
 137           BEGIN     -- (D)
 138                P2 (REC.A (1..4));
 139                IF REC.A /= (5, 5, 5, 5, 9) THEN
 140                     FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
 141                END IF;
 142           EXCEPTION
 143                WHEN OTHERS =>
 144                     FAILED ("EXCEPTION RAISED DURING CALL OF P2");
 145           END;     -- (D)
 146
 147           BEGIN     -- (E)
 148                P3 (REC.A (3..4));
 149                IF REC.A /= (5, 5, 3, 3, 9) THEN
 150                     FAILED ("OUT PARAM RETURNED INCORRECTLY");
 151                END IF;
 152           EXCEPTION
 153                WHEN OTHERS =>
 154                     FAILED ("EXCEPTION RAISED DURING CALL OF P3");
 155           END;     -- (E)
 156
 157      END; -- (A)
 158
 159      RESULT;
 160 END C64109H;