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

   1 -- C64106D.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 ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED
  26 --    RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
  27 --    CONSTRAINTS DO NOT RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER
  28 --    IS UNCONSTRAINED, EVEN IF THE CONSTRAINT VALUES OF THE OBJECT
  29 --    BEING ASSIGNED ARE DIFFERENT THAN THOSE OF THE ACTUAL PARAMETER.
  30
  31 --    SUBTESTS ARE:
  32 --        (A) UNCONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
  33 --        (B) UNCONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
  34 --        (C) UNCONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
  35
  36 -- JRK  4/16/81
  37 -- CPP  8/9/84
  38 -- JRK 11/28/84
  39
  40 WITH REPORT;
  41 PROCEDURE C64106D IS
  42
  43      USE REPORT;
  44
  45 BEGIN
  46
  47      TEST ("C64106D", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " &
  48                       "UNCONSTRAINED TYPES WITH UNCONSTRAINED " &
  49                       "ACTUAL PARAMETERS");
  50
  51      --------------------------------------------------
  52
  53      DECLARE  -- (A)
  54
  55           PACKAGE PKG IS
  56
  57                SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
  58
  59                TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
  60                     RECORD
  61                          INTFLD   : INTRANGE;
  62                          STRFLD   : STRING(1..CONSTRAINT);
  63                     END RECORD;
  64
  65                PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
  66                             REC3 : OUT RECTYPE);
  67           END PKG;
  68
  69           REC91, REC92, REC93 : PKG.RECTYPE :=
  70                (IDENT_INT(5), 5, IDENT_STR("12345"));
  71           REC_OOPS            : PKG.RECTYPE;
  72
  73           PACKAGE BODY PKG IS
  74
  75                PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
  76                             REC3 : OUT RECTYPE) IS
  77
  78                     PROCEDURE P1 (REC11 : IN RECTYPE;
  79                                   REC12 : IN OUT RECTYPE;
  80                                   REC13 : OUT RECTYPE) IS
  81                     BEGIN
  82
  83                          IF NOT REC11'CONSTRAINED THEN
  84                               FAILED ("REC11 IS NOT CONSTRAINED - A.1");
  85                          END IF;
  86                          IF REC11.CONSTRAINT /= IDENT_INT(9) THEN
  87                               FAILED ("REC11 CONSTRAINT IS NOT 9 " &
  88                                       "- A.1");
  89                          END IF;
  90
  91                          BEGIN  -- ASSIGNMENT TO IN OUT PARAMETER
  92                               REC12 := REC_OOPS;
  93                          EXCEPTION
  94                               WHEN OTHERS =>
  95                                    FAILED ("EXCEPTION RAISED - A.1");
  96                          END;
  97
  98                          BEGIN  -- ASSIGNMENT TO OUT PARAMETER
  99                               REC13 := REC_OOPS;
 100                          EXCEPTION
 101                               WHEN OTHERS =>
 102                                    FAILED ("EXCEPTION RAISED - A.2");
 103                          END;
 104                     END P1;
 105
 106                BEGIN
 107                     P1 (REC1, REC2, REC3);
 108                END P;
 109
 110           BEGIN
 111
 112                REC91 := (9, 9, "123456789");
 113                REC92 := REC91;
 114                REC93 := REC91;
 115
 116                REC_OOPS := (4, 4, "OOPS");
 117
 118           END PKG;
 119
 120           USE PKG;
 121
 122      BEGIN  -- (A)
 123
 124           PKG.P (REC91, REC92, REC93);
 125           IF (REC92 /= REC_OOPS) OR (REC93 /= REC_OOPS) THEN
 126                FAILED ("RESULTANT VALUE OF REC92 OR REC93 INCORRECT");
 127           END IF;
 128
 129      END;   -- (A)
 130
 131      --------------------------------------------------
 132
 133      DECLARE  -- (B)
 134
 135           PACKAGE PKG IS
 136
 137                SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
 138
 139                TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
 140
 141                PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
 142                             REC3 : OUT RECTYPE);
 143
 144           PRIVATE
 145
 146                TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
 147                     RECORD
 148                          INTFLD   : INTRANGE;
 149                          STRFLD   : STRING(1..CONSTRAINT);
 150                     END RECORD;
 151           END PKG;
 152
 153           REC91, REC92, REC93  : PKG.RECTYPE;
 154           REC_OOPS             : PKG.RECTYPE;
 155
 156           PACKAGE BODY PKG IS
 157
 158                PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
 159                             REC3 : OUT RECTYPE) IS
 160
 161                     PROCEDURE P1 (REC11 : IN RECTYPE;
 162                                   REC12 : IN OUT RECTYPE;
 163                                   REC13 : OUT RECTYPE) IS
 164                     BEGIN
 165
 166                          IF REC3'CONSTRAINED THEN
 167                               FAILED ("REC3 IS CONSTRAINED - B.1");
 168                          END IF;
 169
 170                          BEGIN  -- ASSIGNMENT TO IN OUT PARAMETER
 171                               REC12 := REC_OOPS;
 172                          EXCEPTION
 173                               WHEN OTHERS =>
 174                                    FAILED ("EXCEPTION RAISED - B.1");
 175                          END;
 176
 177                          BEGIN  -- ASSIGNMENT TO OUT PARAMETER
 178                               REC13 := REC_OOPS;
 179                          EXCEPTION
 180                               WHEN OTHERS =>
 181                                    FAILED ("EXCEPTION RAISED - B.2");
 182                          END;
 183                     END P1;
 184
 185                BEGIN
 186                     P1 (REC1, REC2, REC3);
 187                END P;
 188
 189           BEGIN
 190
 191                REC91 := (9, 9, "123456789");
 192                REC92 := REC91;
 193                REC93 := REC91;
 194
 195                REC_OOPS := (4, 4, "OOPS");
 196
 197           END PKG;
 198
 199      BEGIN  -- (B)
 200
 201           PKG.P (REC91, REC92, REC93);
 202
 203      END;   -- (B)
 204
 205      --------------------------------------------------
 206
 207      DECLARE  -- (C)
 208
 209           PACKAGE PKG IS
 210
 211                SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
 212
 213                TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
 214                     LIMITED PRIVATE;
 215
 216                PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
 217                             REC3 : OUT RECTYPE);
 218
 219           PRIVATE
 220
 221                TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
 222                     RECORD
 223                          INTFLD   : INTRANGE;
 224                          STRFLD   : STRING(1..CONSTRAINT);
 225                     END RECORD;
 226           END PKG;
 227
 228           REC91, REC92, REC93  : PKG.RECTYPE;
 229           REC_OOPS             : PKG.RECTYPE;
 230
 231           PACKAGE BODY PKG IS
 232
 233                PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
 234                             REC3 : OUT RECTYPE) IS
 235
 236                     PROCEDURE P1 (REC11 : IN RECTYPE;
 237                                   REC12 : IN OUT RECTYPE;
 238                                   REC13 : OUT RECTYPE) IS
 239                     BEGIN
 240
 241                          BEGIN  -- ASSIGNMENT TO IN OUT PARAMETER
 242                               REC12 := REC_OOPS;
 243                          EXCEPTION
 244                               WHEN OTHERS =>
 245                                    FAILED ("EXCEPTION RAISED - C.1");
 246                          END;
 247
 248                          BEGIN  -- ASSIGNMENT TO OUT PARAMETER
 249                               REC13 := REC_OOPS;
 250                          EXCEPTION
 251                               WHEN OTHERS =>
 252                                    FAILED ("EXCEPTION RAISED - C.2");
 253                          END;
 254                     END P1;
 255
 256                BEGIN
 257                     P1 (REC1, REC2, REC3);
 258                END P;
 259
 260           BEGIN
 261
 262                REC91 := (9, 9, "123456789");
 263                REC92 := REC91;
 264                REC93 := REC91;
 265
 266                REC_OOPS := (4, 4, "OOPS");
 267
 268           END PKG;
 269
 270      BEGIN  -- (C)
 271
 272           PKG.P (REC91, REC92, REC93);
 273
 274      END;   -- (C)
 275
 276      --------------------------------------------------
 277
 278      RESULT;
 279
 280 END C64106D;