gcc/testsuite/ada/acats/tests/cc/cc3224a.ada

   1 -- CC3224A.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 A FORMAL ARRAY TYPE DENOTES ITS ACTUAL
  26 --     PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE
  27 --     IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE.
  28
  29 -- HISTORY:
  30 --     DHH 09/19/88  CREATED ORIGINAL TEST.
  31 --     EDWARD V. BERARD, 14 AUGUST 1990  ADDED CHECKS FOR MULTI-
  32 --                                       DIMENSIONAL ARRAYS
  33 --     PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
  34
  35 WITH REPORT ;
  36
  37 PROCEDURE CC3224A IS
  38
  39     SUBTYPE INT IS INTEGER RANGE 1 .. 3;
  40     TYPE ARR IS ARRAY(1 .. 3) OF INTEGER;
  41     TYPE B_ARR IS ARRAY(1 .. 3) OF BOOLEAN;
  42
  43     Q : ARR;
  44     R : B_ARR;
  45
  46     GENERIC
  47         TYPE T IS ARRAY(INT) OF INTEGER;
  48     PACKAGE P IS
  49         SUBTYPE SUB_T IS T;
  50         X : SUB_T := (1, 2, 3);
  51     END P;
  52
  53     GENERIC
  54         TYPE T IS ARRAY(INT) OF BOOLEAN;
  55     PACKAGE BOOL IS
  56         SUBTYPE SUB_T IS T;
  57     END BOOL;
  58
  59     SHORT_START : CONSTANT := -100 ;
  60     SHORT_END   : CONSTANT := 100 ;
  61     TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
  62
  63     SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ;
  64
  65     TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
  66                         SEP, OCT, NOV, DEC) ;
  67
  68     SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ;
  69
  70     TYPE DAY_TYPE IS RANGE 1 .. 31 ;
  71     TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
  72     TYPE DATE IS RECORD
  73       MONTH : MONTH_TYPE ;
  74       DAY   : DAY_TYPE ;
  75       YEAR  : YEAR_TYPE ;
  76     END RECORD ;
  77
  78     TODAY         : DATE := (MONTH => AUG,
  79                              DAY   => 8,
  80                              YEAR  => 1990) ;
  81
  82     FIRST_DATE    : DATE := (DAY   => 6,
  83                              MONTH => JUN,
  84                              YEAR  => 1967) ;
  85
  86     WALL_DATE     : DATE := (MONTH => NOV,
  87                              DAY   => 9,
  88                              YEAR  => 1989) ;
  89
  90     SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ;
  91
  92     TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT,
  93                                      FIRST_HALF,
  94                                      FIRST_FIVE) OF DATE ;
  95
  96     TD_ARRAY        : THREE_DIMENSIONAL ;
  97     SECOND_TD_ARRAY : THREE_DIMENSIONAL ;
  98
  99     GENERIC
 100
 101         TYPE CUBE IS ARRAY (REALLY_SHORT,
 102                             FIRST_HALF,
 103                             FIRST_FIVE) OF DATE ;
 104
 105     PACKAGE TD_ARRAY_PACKAGE IS
 106
 107         SUBTYPE SUB_CUBE IS CUBE ;
 108         TEST_3D_ARRAY : SUB_CUBE := (THREE_DIMENSIONAL'RANGE =>
 109                                     (THREE_DIMENSIONAL'RANGE (2) =>
 110                                     (THREE_DIMENSIONAL'RANGE (3) =>
 111                                      TODAY))) ;
 112
 113     END TD_ARRAY_PACKAGE ;
 114
 115
 116 BEGIN  -- CC3224A
 117
 118     REPORT.TEST ("CC3224A", "CHECK THAT A FORMAL ARRAY TYPE DENOTES " &
 119                  "ITS ACTUAL PARAMETER, AND THAT OPERATIONS OF " &
 120                  "THE FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " &
 121                  "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE");
 122
 123     ONE_DIMENSIONAL:
 124
 125     DECLARE
 126
 127         PACKAGE P1 IS NEW P (ARR);
 128
 129         TYPE NEW_T IS NEW P1.SUB_T;
 130         OBJ_NEWT : NEW_T;
 131
 132     BEGIN  -- ONE_DIMENSIONAL
 133
 134         IF NEW_T'FIRST /= ARR'FIRST THEN
 135             REPORT.FAILED("'FIRST ATTRIBUTE REPORT.FAILED");
 136         END IF;
 137
 138         IF NEW_T'LAST /= ARR'LAST THEN
 139             REPORT.FAILED("'LAST ATTRIBUTE REPORT.FAILED");
 140         END IF;
 141
 142         IF NEW_T'FIRST(1) /= ARR'FIRST(1) THEN
 143             REPORT.FAILED("'FIRST(N) ATTRIBUTE REPORT.FAILED");
 144         END IF;
 145
 146         IF NOT (NEW_T'LAST(1) = ARR'LAST(1)) THEN
 147             REPORT.FAILED("'LAST(N) ATTRIBUTE REPORT.FAILED");
 148         END IF;
 149
 150         IF 2 NOT IN NEW_T'RANGE THEN
 151             REPORT.FAILED("'RANGE ATTRIBUTE REPORT.FAILED");
 152         END IF;
 153
 154         IF 3 NOT IN NEW_T'RANGE(1) THEN
 155             REPORT.FAILED("'RANGE(N) ATTRIBUTE REPORT.FAILED");
 156         END IF;
 157
 158         IF NEW_T'LENGTH /= ARR'LENGTH THEN
 159             REPORT.FAILED("'LENGTH ATTRIBUTE REPORT.FAILED");
 160         END IF;
 161
 162         IF NEW_T'LENGTH(1) /= ARR'LENGTH(1) THEN
 163             REPORT.FAILED("'LENGTH(N) ATTRIBUTE REPORT.FAILED");
 164          END IF;
 165
 166         OBJ_NEWT := (1, 2, 3);
 167         IF REPORT.IDENT_INT(3) /= OBJ_NEWT(3) THEN
 168             REPORT.FAILED("ASSIGNMENT REPORT.FAILED");
 169         END IF;
 170
 171         IF NEW_T'(1, 2, 3) NOT IN NEW_T THEN
 172             REPORT.FAILED("QUALIFIED EXPRESSION REPORT.FAILED");
 173         END IF;
 174
 175         Q := (1, 2, 3);
 176         IF NEW_T(Q) /= OBJ_NEWT THEN
 177             REPORT.FAILED("EXPLICIT CONVERSION REPORT.FAILED");
 178         END IF;
 179
 180         IF Q(1) /= OBJ_NEWT(1) THEN
 181             REPORT.FAILED("INDEXING REPORT.FAILED");
 182         END IF;
 183
 184         IF (1, 2) /= OBJ_NEWT(1 .. 2) THEN
 185             REPORT.FAILED("SLICE REPORT.FAILED");
 186         END IF;
 187
 188         IF (1, 2) & OBJ_NEWT(3) /= NEW_T(Q)THEN
 189             REPORT.FAILED("CATENATION REPORT.FAILED");
 190         END IF;
 191
 192         IF NOT (P1.X IN ARR) THEN
 193             REPORT.FAILED ("FORMAL DOES NOT DENOTE ACTUAL");
 194         END IF;
 195
 196     END ONE_DIMENSIONAL ;
 197
 198     BOOLEAN_ONE_DIMENSIONAL:
 199
 200     DECLARE
 201
 202         PACKAGE B1 IS NEW BOOL (B_ARR);
 203
 204         TYPE NEW_T IS NEW B1.SUB_T;
 205         OBJ_NEWT : NEW_T;
 206
 207     BEGIN  -- BOOLEAN_ONE_DIMENSIONAL
 208
 209         OBJ_NEWT := (TRUE, TRUE, TRUE);
 210         R := (TRUE, TRUE, TRUE);
 211
 212         IF (NEW_T'((TRUE, TRUE, TRUE)) XOR OBJ_NEWT) /=
 213            NEW_T'((FALSE, FALSE, FALSE)) THEN
 214             REPORT.FAILED("XOR REPORT.FAILED - BOOLEAN") ;
 215         END IF;
 216
 217         IF (NEW_T'((FALSE, FALSE, TRUE)) AND OBJ_NEWT) /=
 218            NEW_T'((FALSE, FALSE, TRUE)) THEN
 219             REPORT.FAILED("AND REPORT.FAILED - BOOLEAN") ;
 220         END IF;
 221
 222         IF (NEW_T'((FALSE, FALSE, FALSE)) OR OBJ_NEWT) /=
 223            NEW_T'((TRUE, TRUE, TRUE)) THEN
 224             REPORT.FAILED("OR REPORT.FAILED - BOOLEAN") ;
 225         END IF ;
 226
 227     END BOOLEAN_ONE_DIMENSIONAL ;
 228
 229     THREE_DIMENSIONAL_TEST:
 230
 231     DECLARE
 232
 233          PACKAGE TD IS NEW TD_ARRAY_PACKAGE (CUBE => THREE_DIMENSIONAL) ;
 234
 235         TYPE NEW_CUBE IS NEW TD.SUB_CUBE ;
 236         NEW_CUBE_OBJECT : NEW_CUBE ;
 237
 238     BEGIN  -- THREE_DIMENSIONAL_TEST
 239
 240         IF (NEW_CUBE'FIRST /= THREE_DIMENSIONAL'FIRST) OR
 241            (NEW_CUBE'FIRST (1) /= THREE_DIMENSIONAL'FIRST) OR
 242            (NEW_CUBE'FIRST (2) /= THREE_DIMENSIONAL'FIRST (2)) OR
 243            (NEW_CUBE'FIRST (3) /= THREE_DIMENSIONAL'FIRST (3)) THEN
 244             REPORT.FAILED ("PROBLEMS WITH 'FIRST FOR MULTI-" &
 245                            "DIMENSIONAL ARRAYS.") ;
 246         END IF ;
 247
 248         IF (NEW_CUBE'LAST /= THREE_DIMENSIONAL'LAST) OR
 249            (NEW_CUBE'LAST (1) /= THREE_DIMENSIONAL'LAST) OR
 250            (NEW_CUBE'LAST (2) /= THREE_DIMENSIONAL'LAST (2)) OR
 251            (NEW_CUBE'LAST (3) /= THREE_DIMENSIONAL'LAST (3)) THEN
 252             REPORT.FAILED ("PROBLEMS WITH 'LAST FOR MULTI-" &
 253                            "DIMENSIONAL ARRAYS.") ;
 254         END IF ;
 255
 256         IF (-5 NOT IN NEW_CUBE'RANGE) OR
 257            (-3 NOT IN NEW_CUBE'RANGE (1)) OR
 258            (FEB NOT IN NEW_CUBE'RANGE (2)) OR
 259            ('C' NOT IN NEW_CUBE'RANGE (3)) THEN
 260             REPORT.FAILED ("PROBLEMS WITH 'RANGE FOR MULTI-" &
 261                            "DIMENSIONAL ARRAYS.") ;
 262         END IF ;
 263
 264         IF (NEW_CUBE'LENGTH /= THREE_DIMENSIONAL'LENGTH) OR
 265            (NEW_CUBE'LENGTH (1) /= THREE_DIMENSIONAL'LENGTH) OR
 266            (NEW_CUBE'LENGTH (2) /= THREE_DIMENSIONAL'LENGTH (2)) OR
 267            (NEW_CUBE'LENGTH (3) /= THREE_DIMENSIONAL'LENGTH (3)) THEN
 268             REPORT.FAILED ("PROBLEMS WITH 'LENGTH FOR MULTI-" &
 269                            "DIMENSIONAL ARRAYS.") ;
 270         END IF ;
 271
 272         NEW_CUBE_OBJECT := (NEW_CUBE'RANGE =>
 273                            (NEW_CUBE'RANGE (2) =>
 274                            (NEW_CUBE'RANGE (3) =>
 275                             FIRST_DATE))) ;
 276         IF FIRST_DATE /= NEW_CUBE_OBJECT (-3, MAR, 'D') THEN
 277             REPORT.FAILED ("ASSIGNMENT FOR MULTI-DIMENSIONAL " &
 278                            "ARRAYS FAILED.") ;
 279         END IF ;
 280
 281         IF NEW_CUBE'(NEW_CUBE'RANGE =>
 282                     (NEW_CUBE'RANGE (2) =>
 283                     (NEW_CUBE'RANGE (3) =>
 284                      WALL_DATE))) NOT IN NEW_CUBE THEN
 285             REPORT.FAILED ("QUALIFIED EXPRESSION FOR MULTI-" &
 286                            "DIMENSIONAL ARRAYS FAILED.") ;
 287         END IF ;
 288
 289         SECOND_TD_ARRAY := (NEW_CUBE'RANGE =>
 290                            (NEW_CUBE'RANGE (2) =>
 291                            (NEW_CUBE'RANGE (3) =>
 292                             FIRST_DATE))) ;
 293         IF NEW_CUBE (SECOND_TD_ARRAY) /= NEW_CUBE_OBJECT THEN
 294             REPORT.FAILED ("EXPLICIT CONVERSION FOR MULTI-" &
 295                            "DIMENSIONAL ARRAYS FAILED.") ;
 296         END IF ;
 297
 298         IF SECOND_TD_ARRAY (-2, FEB, 'B')
 299             /= NEW_CUBE_OBJECT (-2, FEB, 'B') THEN
 300             REPORT.FAILED ("INDEXING FOR MULTI-" &
 301                            "DIMENSIONAL ARRAYS FAILED.") ;
 302         END IF ;
 303
 304         IF NOT (TD.TEST_3D_ARRAY IN THREE_DIMENSIONAL) THEN
 305             REPORT.FAILED ("FORMAL MULTI-DIMENSIONAL ARRAY " &
 306                            "DOES NOT DENOTE ACTUAL.") ;
 307         END IF ;
 308
 309     END THREE_DIMENSIONAL_TEST ;
 310
 311     REPORT.RESULT ;
 312
 313 END CC3224A ;