gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c6/c64109j.ada

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