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

   1 -- C61010A.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 -- CHECK THAT AN IN OR IN OUT FORMAL PARAMETER CAN BE DECLARED WITH A
  26 -- LIMITED PRIVATE TYPE OR A LIMITED COMPOSITE TYPE.
  27
  28 -- DAS  1/22/81
  29 -- JRK  1/20/84  TOTALLY REVISED.
  30
  31 WITH REPORT; USE REPORT;
  32 PROCEDURE C61010A IS
  33
  34      PACKAGE PKG IS
  35
  36           TYPE ITYPE IS LIMITED PRIVATE;
  37
  38           PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING);
  39
  40           PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
  41                                   M : STRING);
  42
  43           PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER);
  44
  45           SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20;
  46           TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE;
  47
  48           PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
  49                                 S : STRING; M : STRING);
  50
  51           PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
  52                                    I : INTEGER; S : STRING;
  53                                    M : STRING);
  54
  55           PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
  56                             S : STRING);
  57
  58      PRIVATE
  59
  60           TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99;
  61
  62           TYPE VRTYPE (C : INT_0_20 := 20) IS
  63                RECORD
  64                     I : INTEGER;
  65                     S : STRING (1 .. C);
  66                END RECORD;
  67
  68      END PKG;
  69
  70      USE PKG;
  71
  72      I1 : ITYPE;
  73
  74      TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE;
  75
  76      A1 : ATYPE;
  77
  78      VR1 : VRTYPE;
  79
  80      D : CONSTANT INT_0_20 := 10;
  81
  82      TYPE RTYPE IS
  83           RECORD
  84                J : ITYPE;
  85                R : VRTYPE (D);
  86           END RECORD;
  87
  88      R1 : RTYPE;
  89
  90      PACKAGE BODY PKG IS
  91
  92           PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
  93           BEGIN
  94                IF INTEGER (X) /= V THEN
  95                     FAILED ("WRONG SCALAR VALUE - " & M);
  96                END IF;
  97           END LOOK_IN_I;
  98
  99           PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
 100                                   M : STRING) IS
 101           BEGIN
 102                IF INTEGER (X) /= V THEN
 103                     FAILED ("WRONG SCALAR VALUE - " & M);
 104                END IF;
 105           END LOOK_INOUT_I;
 106
 107           PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER) IS
 108           BEGIN
 109                X := ITYPE (IDENT_INT (V));
 110           END SET_I;
 111
 112           PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
 113                                 S : STRING; M : STRING) IS
 114           BEGIN
 115                IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN
 116                     FAILED ("WRONG COMPOSITE VALUE - " & M);
 117                END IF;
 118           END LOOK_IN_VR;
 119
 120           PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
 121                                    I : INTEGER; S : STRING;
 122                                    M : STRING) IS
 123           BEGIN
 124                IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN
 125                     FAILED ("WRONG COMPOSITE VALUE - " & M);
 126                END IF;
 127           END LOOK_INOUT_VR;
 128
 129           PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
 130                             S : STRING) IS
 131           BEGIN
 132                X := (IDENT_INT(C), IDENT_INT(I), IDENT_STR(S));
 133           END SET_VR;
 134
 135      BEGIN
 136           I1 := ITYPE (IDENT_INT(2));
 137
 138           FOR I IN A1'RANGE LOOP
 139                A1 (I) := ITYPE (3 + IDENT_INT(I));
 140           END LOOP;
 141
 142           VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234"));
 143
 144           R1.J := ITYPE (IDENT_INT(6));
 145           R1.R := (IDENT_INT(D), IDENT_INT(19),
 146                    IDENT_STR("ABCDEFGHIJ"));
 147      END PKG;
 148
 149      PROCEDURE CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
 150      BEGIN
 151           LOOK_IN_I (X, V, M);
 152      END CHECK_IN_I;
 153
 154      PROCEDURE CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER;
 155                               NV : INTEGER; M : STRING) IS
 156      BEGIN
 157           LOOK_INOUT_I (X, OV, M & " - A");
 158           SET_I (X, NV);
 159           LOOK_INOUT_I (X, NV, M & " - B");
 160           LOOK_IN_I (X, NV, M & " - C");
 161      END CHECK_INOUT_I;
 162
 163      PROCEDURE CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) IS
 164      BEGIN
 165           FOR I IN X'RANGE LOOP
 166                LOOK_IN_I (X(I), V+I, M & " -" & INTEGER'IMAGE (I));
 167           END LOOP;
 168      END CHECK_IN_A;
 169
 170      PROCEDURE CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER;
 171                               NV : INTEGER; M : STRING) IS
 172      BEGIN
 173           FOR I IN X'RANGE LOOP
 174                LOOK_INOUT_I (X(I), OV+I, M & " - A" &
 175                                          INTEGER'IMAGE (I));
 176                SET_I (X(I), NV+I);
 177                LOOK_INOUT_I (X(I), NV+I, M & " - B" &
 178                                          INTEGER'IMAGE (I));
 179                LOOK_IN_I (X(I), NV+I, M & " - C" & INTEGER'IMAGE (I));
 180           END LOOP;
 181      END CHECK_INOUT_A;
 182
 183      PROCEDURE CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
 184                             S : STRING; M : STRING) IS
 185      BEGIN
 186           LOOK_IN_VR (X, C, I, S, M);
 187      END CHECK_IN_VR;
 188
 189      PROCEDURE CHECK_INOUT_VR (X : IN OUT VRTYPE;
 190                                OC : INTEGER; OI : INTEGER; OS : STRING;
 191                                NC : INTEGER; NI : INTEGER; NS : STRING;
 192                                M : STRING) IS
 193      BEGIN
 194           LOOK_INOUT_VR (X, OC, OI, OS, M & " - A");
 195           SET_VR (X, NC, NI, NS);
 196           LOOK_INOUT_VR (X, NC, NI, NS, M & " - B");
 197           LOOK_IN_VR (X, NC, NI, NS, M & " - C");
 198      END CHECK_INOUT_VR;
 199
 200      PROCEDURE CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER;
 201                            I : INTEGER; S : STRING; M : STRING) IS
 202      BEGIN
 203           LOOK_IN_I (X.J, J, M & " - A");
 204           LOOK_IN_VR (X.R, C, I, S, M & " - B");
 205      END CHECK_IN_R;
 206
 207      PROCEDURE CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER;
 208                               OC : INTEGER; OI : INTEGER; OS : STRING;
 209                               NJ : INTEGER;
 210                               NC : INTEGER; NI : INTEGER; NS : STRING;
 211                               M : STRING) IS
 212      BEGIN
 213           LOOK_INOUT_I (X.J, OJ, M & " - A");
 214           LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B");
 215           SET_I (X.J, NJ);
 216           SET_VR (X.R, NC, NI, NS);
 217           LOOK_INOUT_I (X.J, NJ, M & " - C");
 218           LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D");
 219           LOOK_IN_I (X.J, NJ, M & " - E");
 220           LOOK_IN_VR (X.R, NC, NI, NS, M & " - F");
 221      END CHECK_INOUT_R;
 222
 223 BEGIN
 224      TEST ("C61010A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " &
 225                       "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS");
 226
 227      CHECK_IN_I (I1, 2, "IN I");
 228
 229      CHECK_INOUT_I (I1, 2, 5, "INOUT I");
 230
 231      CHECK_IN_A (A1, 3, "IN A");
 232
 233      CHECK_INOUT_A (A1, 3, 17, "INOUT A");
 234
 235      CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR");
 236
 237      CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210",
 238                      "INOUT VR");
 239
 240      CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R");
 241
 242      CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, "ZYXWVUTSRQ",
 243                     "INOUT R");
 244
 245      RESULT;
 246 END C61010A;