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 35WITH REPORT ; 36 37PROCEDURE 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 116BEGIN -- 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 313END CC3224A ; 314