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

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