1-- C34005O.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-- OBJECTIVE: 26-- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE 27-- IS A NON-LIMITED TYPE: 28-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR 29-- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS 30-- CONSTRAINED. 31-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO 32-- IMPOSED ON THE DERIVED SUBTYPE. 33 34-- HISTORY: 35-- JRK 9/17/86 CREATED ORIGINAL TEST. 36 37WITH REPORT; USE REPORT; 38 39PROCEDURE C34005O IS 40 41 SUBTYPE COMPONENT IS INTEGER; 42 43 PACKAGE PKG IS 44 45 FIRST : CONSTANT := 0; 46 LAST : CONSTANT := 10; 47 48 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; 49 50 TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF 51 COMPONENT; 52 53 FUNCTION CREATE ( F1, L1 : INDEX; 54 F2, L2 : INDEX; 55 C : COMPONENT; 56 DUMMY : PARENT -- TO RESOLVE OVERLOADING. 57 ) RETURN PARENT; 58 59 END PKG; 60 61 USE PKG; 62 63 TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), 64 IDENT_INT (6) .. IDENT_INT (8)); 65 66 SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8); 67 68 TYPE S IS NEW SUBPARENT; 69 70 X : T := (OTHERS => (OTHERS => 2)); 71 Y : S := (OTHERS => (OTHERS => 2)); 72 73 PACKAGE BODY PKG IS 74 75 FUNCTION CREATE 76 ( F1, L1 : INDEX; 77 F2, L2 : INDEX; 78 C : COMPONENT; 79 DUMMY : PARENT 80 ) RETURN PARENT 81 IS 82 A : PARENT (F1 .. L1, F2 .. L2); 83 B : COMPONENT := C; 84 BEGIN 85 FOR I IN F1 .. L1 LOOP 86 FOR J IN F2 .. L2 LOOP 87 A (I, J) := B; 88 B := B + 1; 89 END LOOP; 90 END LOOP; 91 RETURN A; 92 END CREATE; 93 94 END PKG; 95 96BEGIN 97 TEST ("C34005O", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 98 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 99 "WHEN THE DERIVED TYPE DEFINITION IS " & 100 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 101 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 102 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 103 "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & 104 "TYPE IS A NON-LIMITED TYPE"); 105 106 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 107 108 BEGIN 109 IF CREATE (6, 9, 2, 3, 1, X) /= 110 ((1, 2), (3, 4), (5, 6), (7, 8)) OR 111 CREATE (6, 9, 2, 3, 1, Y) /= 112 ((1, 2), (3, 4), (5, 6), (7, 8)) THEN 113 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & 114 "SUBTYPE"); 115 END IF; 116 EXCEPTION 117 WHEN CONSTRAINT_ERROR => 118 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); 119 WHEN OTHERS => 120 FAILED ("CALL TO CREATE RAISED EXCEPTION"); 121 END; 122 123 IF ((1, 2), (3, 4), (5, 6), (7, 8)) IN T OR 124 ((1, 2), (3, 4), (5, 6), (7, 8)) IN S THEN 125 FAILED ("INCORRECT ""IN"""); 126 END IF; 127 128 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 129 130 IF T'FIRST /= 4 OR T'LAST /= 5 OR 131 S'FIRST /= 4 OR S'LAST /= 5 OR 132 T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR 133 S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN 134 FAILED ("INCORRECT 'FIRST OR 'LAST"); 135 END IF; 136 137 BEGIN 138 X := ((1, 2, 3), (4, 5, 6)); 139 Y := ((1, 2, 3), (4, 5, 6)); 140 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. 141 FAILED ("INCORRECT CONVERSION TO PARENT"); 142 END IF; 143 EXCEPTION 144 WHEN OTHERS => 145 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); 146 END; 147 148 BEGIN 149 X := (4 => (6 .. 8 => 0)); 150 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 151 "X := (4 => (6 .. 8 => 0))"); 152 IF X = (4 => (6 .. 8 => 0)) THEN -- USE X. 153 COMMENT ("X ALTERED -- " & 154 "X := (4 => (6 .. 8 => 0))"); 155 END IF; 156 EXCEPTION 157 WHEN CONSTRAINT_ERROR => 158 NULL; 159 WHEN OTHERS => 160 FAILED ("WRONG EXCEPTION RAISED -- " & 161 "X := (4 => (6 .. 8 => 0))"); 162 END; 163 164 BEGIN 165 X := (4 .. 6 => (6 .. 8 => 0)); 166 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 167 "X := (4 .. 6 => (6 .. 8 => 0))"); 168 IF X = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE X. 169 COMMENT ("X ALTERED -- " & 170 "X := (4 .. 6 => (6 .. 8 => 0))"); 171 END IF; 172 EXCEPTION 173 WHEN CONSTRAINT_ERROR => 174 NULL; 175 WHEN OTHERS => 176 FAILED ("WRONG EXCEPTION RAISED -- " & 177 "X := (4 .. 6 => (6 .. 8 => 0))"); 178 END; 179 180 BEGIN 181 X := (4 .. 5 => (6 .. 7 => 0)); 182 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 183 "X := (4 .. 5 => (6 .. 7 => 0))"); 184 IF X = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE X. 185 COMMENT ("X ALTERED -- " & 186 "X := (4 .. 5 => (6 .. 7 => 0))"); 187 END IF; 188 EXCEPTION 189 WHEN CONSTRAINT_ERROR => 190 NULL; 191 WHEN OTHERS => 192 FAILED ("WRONG EXCEPTION RAISED -- " & 193 "X := (4 .. 5 => (6 .. 7 => 0))"); 194 END; 195 196 BEGIN 197 X := (4 .. 5 => (6 .. 9 => 0)); 198 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 199 "X := (4 .. 5 => (6 .. 9 => 0))"); 200 IF X = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE X. 201 COMMENT ("X ALTERED -- " & 202 "X := (4 .. 5 => (6 .. 9 => 0))"); 203 END IF; 204 EXCEPTION 205 WHEN CONSTRAINT_ERROR => 206 NULL; 207 WHEN OTHERS => 208 FAILED ("WRONG EXCEPTION RAISED -- " & 209 "X := (4 .. 5 => (6 .. 9 => 0))"); 210 END; 211 212 BEGIN 213 Y := (4 => (6 .. 8 => 0)); 214 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 215 "Y := (4 => (6 .. 8 => 0))"); 216 IF Y = (4 => (6 .. 8 => 0)) THEN -- USE Y. 217 COMMENT ("Y ALTERED -- " & 218 "Y := (4 => (6 .. 8 => 0))"); 219 END IF; 220 EXCEPTION 221 WHEN CONSTRAINT_ERROR => 222 NULL; 223 WHEN OTHERS => 224 FAILED ("WRONG EXCEPTION RAISED -- " & 225 "Y := (4 => (6 .. 8 => 0))"); 226 END; 227 228 BEGIN 229 Y := (4 .. 6 => (6 .. 8 => 0)); 230 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 231 "Y := (4 .. 6 => (6 .. 8 => 0))"); 232 IF Y = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE Y. 233 COMMENT ("Y ALTERED -- " & 234 "Y := (4 .. 6 => (6 .. 8 => 0))"); 235 END IF; 236 EXCEPTION 237 WHEN CONSTRAINT_ERROR => 238 NULL; 239 WHEN OTHERS => 240 FAILED ("WRONG EXCEPTION RAISED -- " & 241 "Y := (4 .. 6 => (6 .. 8 => 0))"); 242 END; 243 244 BEGIN 245 Y := (4 .. 5 => (6 .. 7 => 0)); 246 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 247 "Y := (4 .. 5 => (6 .. 7 => 0))"); 248 IF Y = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE Y. 249 COMMENT ("Y ALTERED -- " & 250 "Y := (4 .. 5 => (6 .. 7 => 0))"); 251 END IF; 252 EXCEPTION 253 WHEN CONSTRAINT_ERROR => 254 NULL; 255 WHEN OTHERS => 256 FAILED ("WRONG EXCEPTION RAISED -- " & 257 "Y := (4 .. 5 => (6 .. 7 => 0))"); 258 END; 259 260 BEGIN 261 Y := (4 .. 5 => (6 .. 9 => 0)); 262 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 263 "Y := (4 .. 5 => (6 .. 9 => 0))"); 264 IF Y = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE Y. 265 COMMENT ("Y ALTERED -- " & 266 "Y := (4 .. 5 => (6 .. 9 => 0))"); 267 END IF; 268 EXCEPTION 269 WHEN CONSTRAINT_ERROR => 270 NULL; 271 WHEN OTHERS => 272 FAILED ("WRONG EXCEPTION RAISED -- " & 273 "Y := (4 .. 5 => (6 .. 9 => 0))"); 274 END; 275 276 RESULT; 277END C34005O; 278