gcc/testsuite/ada/acats/tests/c6/c64109l.ada

   1 -- C64109L.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 --       (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN
  29 --       ANOTHER SUBPROGRAM CALL.
  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 C64109L IS
  37
  38 BEGIN
  39      TEST ("C64109L", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
  40                       "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
  41                       "TO SUBPROGRAMS - FORMAL AS AN ACTUAL");
  42
  43      DECLARE   -- (F)
  44
  45           TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
  46           SUBTYPE ARRAY_SUBTYPE IS
  47                     ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5));
  48           TYPE RECORD_TYPE IS
  49                RECORD
  50                     I : INTEGER;
  51                     A : ARRAY_SUBTYPE;
  52                END RECORD;
  53           REC : RECORD_TYPE := (I => 23,
  54                                 A => (1..3 => 7, 4..5 => 9));
  55           BOOL : BOOLEAN;
  56
  57           PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS
  58           BEGIN
  59                IF A /= (7, 7, 7) THEN
  60                     FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY");
  61                END IF;
  62                IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(3) THEN
  63                     FAILED ("BOUNDS WRONG - IN OUT");
  64                END IF;
  65                A := (A'RANGE => 6);
  66           EXCEPTION
  67                WHEN OTHERS =>
  68                     FAILED ("EXCEPTION RAISED IN PROCEDURE P_CALLED");
  69           END P_CALLED;
  70
  71           PROCEDURE P (A : IN OUT ARRAY_TYPE) IS
  72           BEGIN
  73                P_CALLED (A);
  74           EXCEPTION
  75                WHEN OTHERS =>
  76                     FAILED ("EXCEPTION RAISED IN PROCEDURE P");
  77           END P;
  78
  79           FUNCTION F_CALLED (A : ARRAY_TYPE) RETURN BOOLEAN IS
  80                GOOD : BOOLEAN;
  81           BEGIN
  82                GOOD := (A = (6, 9, 9));
  83                IF NOT GOOD THEN
  84                     FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY");
  85                END IF;
  86                IF A'FIRST /= 3 OR A'LAST /= IDENT_INT(5) THEN
  87                     FAILED ("BOUNDS WRONG - FUNCTION");
  88                END IF;
  89                RETURN GOOD;
  90           EXCEPTION
  91                WHEN OTHERS =>
  92                     FAILED ("EXCEPTION RAISED IN FUNCTION F_CALLED");
  93           END F_CALLED;
  94
  95           FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS
  96           BEGIN
  97                RETURN (F_CALLED (A));
  98           EXCEPTION
  99                WHEN OTHERS =>
 100                     FAILED ("EXCEPTION RAISED IN FUNCTION F");
 101           END F;
 102
 103           PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS
 104           BEGIN
 105                IF A'FIRST /= IDENT_INT(2) OR A'LAST /= 4 THEN
 106                     FAILED ("BOUNDS WRONG - OUT");
 107                END IF;
 108                A := (8, 8, 8);
 109           EXCEPTION
 110                WHEN OTHERS =>
 111                     FAILED ("EXCEPTION RAISED IN PROCEDURE " &
 112                                  "P_OUT_CALLED");
 113           END P_OUT_CALLED;
 114
 115           PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS
 116           BEGIN
 117                P_OUT_CALLED (A);
 118           EXCEPTION
 119                WHEN OTHERS =>
 120                     FAILED ("EXCEPTION RAISED IN PROCEDURE P_OUT");
 121           END P_OUT;
 122
 123      BEGIN     -- (F)
 124
 125           BEGIN     -- (G)
 126                P (REC.A (1..3));
 127                IF REC.A /= (6, 6, 6, 9, 9) THEN
 128                     FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
 129                END IF;
 130           EXCEPTION
 131                WHEN OTHERS =>
 132                     FAILED ("EXCEPTION RAISED DURING CALL OF P");
 133           END;     -- (G)
 134
 135           BEGIN     -- (H)
 136                BOOL := F (REC.A (3..5));
 137                IF NOT BOOL THEN
 138                     FAILED ("IN PARAM NOT RETURNED CORRECTLY");
 139                END IF;
 140           EXCEPTION
 141                WHEN OTHERS =>
 142                     FAILED ("EXCEPTION RAISED DURING CALL OF F");
 143           END;     -- (H)
 144
 145           BEGIN     -- (I)
 146                P_OUT (REC.A (2..4));
 147                IF REC.A /= (6, 8, 8, 8, 9) THEN
 148                     FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2");
 149                END IF;
 150           EXCEPTION
 151                WHEN OTHERS =>
 152                     FAILED ("EXCEPTION RAISED DURING CALL OF P_OUT");
 153           END;     -- (I)
 154
 155      END; -- (F)
 156
 157      RESULT;
 158 END C64109L;