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

   1 -- C64106A.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 UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY
  26 --   FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS.
  27 --   SUBTESTS ARE:
  28 --        (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS.
  29 --        (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS.
  30 --        (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS.
  31 --        (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS.
  32
  33 -- DAS  1/15/81
  34 -- JBG  5/16/83
  35 -- CPP  5/22/84
  36
  37 WITH REPORT;
  38 PROCEDURE C64106A IS
  39
  40      USE REPORT;
  41
  42 BEGIN
  43      TEST ("C64106A", "CHECK USE OF ACTUAL CONSTRAINTS BY " &
  44                       "UNCONSTRAINED FORMAL PARAMETERS");
  45
  46      DECLARE  -- (A)
  47
  48           PACKAGE PKG IS
  49
  50               SUBTYPE INT IS INTEGER RANGE 0..100;
  51
  52               TYPE RECTYPE (CONSTRAINT : INT := 80) IS
  53                     RECORD
  54                          INTFIELD  : INTEGER;
  55                          STRFIELD  : STRING (1..CONSTRAINT);
  56                     END RECORD;
  57
  58                REC1  : RECTYPE   := (10,10,"0123456789");
  59                REC2  : RECTYPE   := (17,7,"C64106A..........");
  60                REC3  : RECTYPE   := (1,1,"A");
  61                REC4  : RECTYPE;  -- 80
  62
  63                PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
  64                                        REC2 : OUT RECTYPE;
  65                                        REC3 : IN OUT RECTYPE);
  66
  67                PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
  68           END PKG;
  69
  70           PACKAGE BODY PKG IS
  71
  72                PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
  73                                        REC2 : OUT RECTYPE;
  74                                        REC3 : IN OUT RECTYPE) IS
  75                BEGIN
  76                     IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
  77                          FAILED ("RECORD TYPE IN PARAMETER DID " &
  78                                  "NOT USE CONSTRAINT OF ACTUAL");
  79                     END IF;
  80                     IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
  81                          FAILED ("RECORD TYPE OUT PARAMETER DID " &
  82                                  "NOT USE CONSTRAINT OF ACTUAL");
  83                     END IF;
  84                     IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
  85                          FAILED ("RECORD TYPE IN OUT PARAMETER DID " &
  86                                  "NOT USE CONSTRAINT OF ACTUAL");
  87                     END IF;
  88                     REC2 := PKG.REC2;
  89                END CHK_RECTYPE1;
  90
  91                PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
  92                BEGIN
  93                     IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
  94                          FAILED ("RECORD TYPE OUT PARAMETER DID " &
  95                                  "NOT USE CONSTRAINT OF " &
  96                                  "UNINITIALIZED ACTUAL");
  97                     END IF;
  98                     REC := (10,10,"9876543210");
  99                END CHK_RECTYPE2;
 100           END PKG;
 101
 102      BEGIN  -- (A)
 103
 104           PKG.CHK_RECTYPE1 (PKG.REC1, PKG.REC2, PKG.REC3);
 105           PKG.CHK_RECTYPE2 (PKG.REC4);
 106
 107      END;   -- (A)
 108
 109      ---------------------------------------------
 110
 111 B :  DECLARE  -- (B)
 112
 113           PACKAGE PKG IS
 114
 115                SUBTYPE INT IS INTEGER RANGE 0..100;
 116
 117                TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE;
 118
 119
 120                PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
 121                                        REC2 : OUT RECTYPE;
 122                                        REC3 : IN OUT RECTYPE);
 123
 124                PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
 125
 126           PRIVATE
 127                TYPE RECTYPE (CONSTRAINT : INT := 80) IS
 128                     RECORD
 129                          INTFIELD  : INTEGER;
 130                          STRFIELD  : STRING (1..CONSTRAINT);
 131                     END RECORD;
 132           END PKG;
 133
 134           REC1  : PKG.RECTYPE(10);
 135           REC2  : PKG.RECTYPE(17);
 136           REC3  : PKG.RECTYPE(1);
 137           REC4  : PKG.RECTYPE(10);
 138
 139           PACKAGE BODY PKG IS
 140
 141                PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
 142                                        REC2 : OUT RECTYPE;
 143                                        REC3 : IN OUT RECTYPE) IS
 144                BEGIN
 145                     IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
 146                          FAILED ("PRIVATE TYPE IN PARAMETER DID " &
 147                                  "NOT USE CONSTRAINT OF ACTUAL");
 148                     END IF;
 149                     IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
 150                          FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
 151                                  "NOT USE CONSTRAINT OF ACTUAL");
 152                     END IF;
 153                     IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
 154                          FAILED ("PRIVATE TYPE IN OUT PARAMETER DID " &
 155                                  "NOT USE CONSTRAINT OF ACTUAL");
 156                     END IF;
 157                     REC2 := B.REC2;
 158                END CHK_RECTYPE1;
 159
 160                PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
 161                BEGIN
 162                     IF (REC.CONSTRAINT /= IDENT_INT(10)) THEN
 163                          FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
 164                                  "NOT USE CONSTRAINT OF " &
 165                                  "UNINITIALIZED ACTUAL");
 166                     END IF;
 167                     REC := (10,10,"9876543210");
 168                END CHK_RECTYPE2;
 169
 170           BEGIN
 171                REC1 := (10,10,"0123456789");
 172                REC2 := (17,7,"C64106A..........");
 173                REC3 := (1,1,"A");
 174
 175           END PKG;
 176
 177      BEGIN  -- (B)
 178
 179           PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
 180           PKG.CHK_RECTYPE2 (REC4);
 181
 182      END B;  -- (B)
 183
 184      ---------------------------------------------
 185
 186 C :  DECLARE  -- (C)
 187
 188           PACKAGE PKG IS
 189
 190                SUBTYPE INT IS INTEGER RANGE 0..100;
 191
 192                TYPE RECTYPE (CONSTRAINT : INT := 80) IS
 193                     LIMITED PRIVATE;
 194
 195                PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
 196                                        REC2 : OUT RECTYPE;
 197                                        REC3 : IN OUT RECTYPE);
 198
 199                PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
 200
 201           PRIVATE
 202                TYPE RECTYPE (CONSTRAINT : INT := 80) IS
 203                     RECORD
 204                          INTFIELD  : INTEGER;
 205                          STRFIELD  : STRING (1..CONSTRAINT);
 206                     END RECORD;
 207           END PKG;
 208
 209           REC1  : PKG.RECTYPE;     -- 10
 210           REC2  : PKG.RECTYPE;     -- 17
 211           REC3  : PKG.RECTYPE;     --  1
 212           REC4  : PKG.RECTYPE;     -- 80
 213
 214           PACKAGE BODY PKG IS
 215
 216                PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
 217                                        REC2 : OUT RECTYPE;
 218                                        REC3 : IN OUT RECTYPE) IS
 219                BEGIN
 220                     IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
 221                          FAILED ("LIMITED PRIVATE TYPE IN PARAMETER " &
 222                                  "DID NOT USE CONSTRAINT OF " &
 223                                  "ACTUAL");
 224                     END IF;
 225                     IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
 226                          FAILED ("LIMITED PRIVATE TYPE OUT PARAMETER " &
 227                                  "DID NOT USE CONSTRAINT OF " &
 228                                  "ACTUAL");
 229                     END IF;
 230                     IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
 231                          FAILED ("LIMITED PRIVATE TYPE IN OUT " &
 232                                  "PARAMETER DID NOT USE " &
 233                                  "CONSTRAINT OF ACTUAL");
 234                     END IF;
 235                     REC2 := C.REC2;
 236                END CHK_RECTYPE1;
 237
 238                PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
 239                BEGIN
 240                     IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
 241                          FAILED ("LIMITED PRIVATE TYPE OUT " &
 242                                  "PARAMETER DID NOT USE " &
 243                                  "CONSTRAINT OF UNINITIALIZED ACTUAL");
 244                     END IF;
 245                     REC := (10,10,"9876543210");
 246                END CHK_RECTYPE2;
 247
 248           BEGIN
 249                REC1 := (10,10,"0123456789");
 250                REC2 := (17,7,"C64106A..........");
 251                REC3 := (1,1,"A");
 252           END PKG;
 253
 254      BEGIN  -- (C)
 255
 256           PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
 257           PKG.CHK_RECTYPE2 (REC4);
 258
 259      END C;   -- (C)
 260
 261      ---------------------------------------------
 262
 263 D :  DECLARE  -- (D)
 264
 265           TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF
 266                CHARACTER;
 267
 268           A1, A2, A3  : ATYPE(-1..1, 4..5)  := (('A','B'),
 269                                                 ('C','D'),
 270                                                 ('E','F'));
 271
 272           A4  : ATYPE(-1..1, 4..5);
 273
 274           CA1 : CONSTANT ATYPE(8..9, -7..INTEGER'FIRST) :=
 275                               (8..9 => (-7..INTEGER'FIRST => 'A'));
 276
 277           S1  : STRING(1..INTEGER'FIRST) := "";
 278           S2  : STRING(-5..-7) := "";
 279           S3  : STRING(1..0) := "";
 280
 281           PROCEDURE CHK_ARRAY1 (A1 : IN ATYPE := CA1;  A2 : OUT ATYPE;
 282                                 A3 : IN OUT ATYPE) IS
 283           BEGIN
 284                IF ((A1'FIRST(1) /= IDENT_INT(-1)) OR
 285                    (A1'LAST(1)  /= IDENT_INT(1)) OR
 286                    (A1'FIRST(2) /= IDENT_INT(4)) OR
 287                    (A1'LAST(2)  /= IDENT_INT(5))) THEN
 288                     FAILED ("ARRAY TYPE IN PARAMETER DID NOT " &
 289                             "USE CONSTRAINTS OF ACTUAL");
 290                END IF;
 291                IF ((A2'FIRST(1) /= IDENT_INT(-1)) OR
 292                    (A2'LAST(1)  /= IDENT_INT(1)) OR
 293                    (A2'FIRST(2) /= IDENT_INT(4)) OR
 294                    (A2'LAST(2)  /= IDENT_INT(5))) THEN
 295                     FAILED ("ARRAY TYPE OUT PARAMETER DID NOT USE" &
 296                             "CONSTRAINTS OF ACTUAL");
 297                END IF;
 298                IF ((A3'FIRST(1) /= IDENT_INT(-1)) OR
 299                    (A3'LAST(1)  /= IDENT_INT(1)) OR
 300                    (A3'FIRST(2) /= IDENT_INT(4)) OR
 301                    (A3'LAST(2)  /= IDENT_INT(5))) THEN
 302                     FAILED ("ARRAY TYPE IN OUT PARAMETER DID NOT " &
 303                             "USE CONSTRAINTS OF ACTUAL");
 304                END IF;
 305                A2 := D.A2;
 306           END CHK_ARRAY1;
 307
 308           PROCEDURE CHK_ARRAY2 (A4 : OUT ATYPE) IS
 309           BEGIN
 310                IF ((A4'FIRST(1) /= IDENT_INT(-1)) OR
 311                    (A4'LAST(1)  /= IDENT_INT(1)) OR
 312                    (A4'FIRST(2) /= IDENT_INT(4)) OR
 313                    (A4'LAST(2)  /= IDENT_INT(5))) THEN
 314                     FAILED ("ARRAY TYPE OUT PARAMETER DID NOT " &
 315                             "USE CONSTRAINTS OF UNINITIALIZED " &
 316                             "ACTUAL");
 317                END IF;
 318                A4 := A2;
 319           END CHK_ARRAY2;
 320
 321           PROCEDURE CHK_STRING (S1 : IN STRING;
 322                                 S2 : IN OUT STRING;
 323                                 S3 : OUT STRING) IS
 324           BEGIN
 325                IF ((S1'FIRST /= IDENT_INT(1)) OR
 326                    (S1'LAST  /= IDENT_INT(INTEGER'FIRST))) THEN
 327                     FAILED ("STRING TYPE IN PARAMETER DID NOT " &
 328                             "USE CONSTRAINTS OF ACTUAL NULL " &
 329                             "STRING");
 330                END IF;
 331                IF ((S2'FIRST /= IDENT_INT(-5)) OR
 332                    (S2'LAST  /= IDENT_INT(-7))) THEN
 333                     FAILED ("STRING TYPE IN OUT PARAMETER DID NOT " &
 334                             "USE CONSTRAINTS OF ACTUAL NULL STRING");
 335                END IF;
 336                IF ((S3'FIRST /= IDENT_INT(1)) OR
 337                    (S3'LAST  /= IDENT_INT(0))) THEN
 338                     FAILED ("STRING TYPE OUT PARAMETER DID NOT " &
 339                             "USE CONSTRAINTS OF ACTUAL NULL STRING");
 340                END IF;
 341                S3 := "";
 342           END CHK_STRING;
 343
 344      BEGIN  -- (D)
 345           CHK_ARRAY1 (A1, A2, A3);
 346           CHK_ARRAY2 (A4);
 347           CHK_STRING (S1, S2, S3);
 348      END D;  -- (D)
 349
 350      RESULT;
 351 END C64106A;