1-- CC3128A.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-- CHECK THAT, FOR A CONSTRAINED IN FORMAL PARAMETER HAVING AN ACCESS TYPE, 27-- CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL PARAMETER IS NOT 28-- NULL AND THE OBJECT DESIGNATED BY THE ACTUAL PARAMETER DOES NOT SATISFY 29-- THE FORMAL PARAMETER'S CONSTRAINTS. 30 31-- HISTORY: 32-- RJW 10/28/88 CREATED ORIGINAL TEST. 33-- JRL 02/28/96 Removed cases where the designated subtypes of the formal 34-- and actual do not statically match. Corrected commentary. 35 36WITH REPORT; USE REPORT; 37PROCEDURE CC3128A IS 38 39BEGIN 40 TEST ("CC3128A", "FOR A CONSTRAINED IN FORMAL PARAMETER HAVING " & 41 "AN ACCESS TYPE, CONSTRAINT_ERROR IS RAISED " & 42 "IF AND ONLY IF THE ACTUAL PARAMETER IS NOT " & 43 "NULL AND THE OBJECT DESIGNATED BY THE ACTUAL " & 44 "PARAMETER DOES NOT SATISFY FORMAL PARAMETER'S " & 45 "CONSTRAINTS"); 46 47 DECLARE 48 TYPE REC (D : INTEGER := 10) IS 49 RECORD 50 NULL; 51 END RECORD; 52 53 TYPE ACCREC IS ACCESS REC; 54 55 SUBTYPE LINK IS ACCREC (5); 56 57 GENERIC 58 LINK1 : LINK; 59 FUNCTION F (I : INTEGER) RETURN INTEGER; 60 61 FUNCTION F (I : INTEGER) RETURN INTEGER IS 62 BEGIN 63 IF I /= 5 THEN 64 FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & 65 "TO CALL TO FUNCTION F - 1"); 66 END IF; 67 IF NOT EQUAL (I, 5) AND THEN 68 NOT EQUAL (LINK1.D, LINK1.D) THEN 69 COMMENT ("DISREGARD"); 70 END IF; 71 RETURN I + 1; 72 EXCEPTION 73 WHEN OTHERS => 74 FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 1"); 75 RETURN I + 1; 76 END F; 77 78 GENERIC 79 TYPE PRIV (D : INTEGER) IS PRIVATE; 80 PRIV1 : PRIV; 81 PACKAGE GEN IS 82 TYPE ACCPRIV IS ACCESS PRIV; 83 SUBTYPE LINK IS ACCPRIV (5); 84 GENERIC 85 LINK1 : LINK; 86 I : IN OUT INTEGER; 87 PACKAGE P IS END P; 88 END GEN; 89 90 PACKAGE BODY GEN IS 91 PACKAGE BODY P IS 92 BEGIN 93 IF I /= 5 THEN 94 FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & 95 "TO PACKAGE BODY P - 1"); 96 END IF; 97 IF NOT EQUAL (I, 5) AND THEN 98 NOT EQUAL (LINK1.D, LINK1.D) THEN 99 COMMENT ("DISREGARD"); 100 END IF; 101 I := I + 1; 102 EXCEPTION 103 WHEN OTHERS => 104 FAILED ("EXCEPTION RAISED WITHIN " & 105 "PACKAGE P - 1"); 106 I := I + 1; 107 END P; 108 109 BEGIN 110 BEGIN 111 DECLARE 112 AR10 : ACCPRIV; 113 I : INTEGER := IDENT_INT (5); 114 PACKAGE P1 IS NEW P (AR10, I); 115 BEGIN 116 IF I /= 6 THEN 117 FAILED ("INCORRECT RESULT - " & 118 "PACKAGE P1"); 119 END IF; 120 EXCEPTION 121 WHEN OTHERS => 122 FAILED ("EXCEPTION RAISED TOO LATE - " & 123 "PACKAGE P1 - 1"); 124 END; 125 EXCEPTION 126 WHEN OTHERS => 127 FAILED ("EXCEPTION RAISED AT INSTANTIATION " & 128 "OF PACKAGE P1 WITH NULL ACCESS " & 129 "VALUE"); 130 END; 131 132 BEGIN 133 DECLARE 134 AR10 : ACCPRIV := NEW PRIV'(PRIV1); 135 I : INTEGER := IDENT_INT (0); 136 PACKAGE P1 IS NEW P (AR10, I); 137 BEGIN 138 FAILED ("NO EXCEPTION RAISED BY " & 139 "INSTANTIATION OF PACKAGE P1"); 140 EXCEPTION 141 WHEN OTHERS => 142 FAILED ("EXCEPTION RAISED TOO LATE - " & 143 "PACKAGE P1 - 2"); 144 END; 145 EXCEPTION 146 WHEN CONSTRAINT_ERROR => 147 NULL; 148 WHEN OTHERS => 149 FAILED ("WRONG EXCEPTION RAISED AT " & 150 "INSTANTIATION OF PACKAGE P1"); 151 END; 152 END GEN; 153 154 PACKAGE NEWGEN IS NEW GEN (REC, (D => 10)); 155 156 BEGIN 157 BEGIN 158 DECLARE 159 I : INTEGER := IDENT_INT (5); 160 AR10 : ACCREC; 161 FUNCTION F1 IS NEW F (AR10); 162 BEGIN 163 I := F1 (I); 164 IF I /= 6 THEN 165 FAILED ("INCORRECT RESULT RETURNED BY " & 166 "FUNCTION F1"); 167 END IF; 168 EXCEPTION 169 WHEN OTHERS => 170 FAILED ("EXCEPTION RAISED AT CALL TO " & 171 "FUNCTION F1 - 1"); 172 END; 173 EXCEPTION 174 WHEN OTHERS => 175 FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " & 176 "FUNCTION F1 WITH NULL ACCESS VALUE"); 177 END; 178 179 BEGIN 180 DECLARE 181 I : INTEGER := IDENT_INT (0); 182 AR10 : ACCREC := NEW REC'(D => 10); 183 FUNCTION F1 IS NEW F (AR10); 184 BEGIN 185 FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " & 186 "OF FUNCTION F1"); 187 I := F1 (I); 188 EXCEPTION 189 WHEN OTHERS => 190 FAILED ("EXCEPTION RAISED AT CALL TO " & 191 "FUNCTION F1 - 2"); 192 END; 193 EXCEPTION 194 WHEN CONSTRAINT_ERROR => 195 NULL; 196 WHEN OTHERS => 197 FAILED ("WRONG EXCEPTION RAISED AT " & 198 "INSTANTIATION OF FUNCTION F1"); 199 END; 200 END; 201 202 DECLARE 203 TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; 204 205 TYPE ACCARR IS ACCESS ARR; 206 207 SUBTYPE LINK IS ACCARR (1 .. 5); 208 209 GENERIC 210 LINK1 : LINK; 211 FUNCTION F (I : INTEGER) RETURN INTEGER; 212 213 FUNCTION F (I : INTEGER) RETURN INTEGER IS 214 BEGIN 215 IF I /= 5 THEN 216 FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & 217 "TO CALL TO FUNCTION F - 2"); 218 END IF; 219 IF NOT EQUAL (I, 5) AND THEN 220 NOT EQUAL (LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3))) 221 THEN 222 COMMENT ("DISREGARD"); 223 END IF; 224 RETURN I + 1; 225 EXCEPTION 226 WHEN OTHERS => 227 FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 2"); 228 RETURN I + 1; 229 END F; 230 231 GENERIC 232 TYPE GENARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; 233 PACKAGE GEN IS 234 TYPE ACCGENARR IS ACCESS GENARR; 235 SUBTYPE LINK IS ACCGENARR (1 .. 5); 236 GENERIC 237 LINK1 : LINK; 238 I : IN OUT INTEGER; 239 PACKAGE P IS END P; 240 END GEN; 241 242 PACKAGE BODY GEN IS 243 PACKAGE BODY P IS 244 BEGIN 245 IF I /= 5 THEN 246 FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & 247 "TO PACKAGE BODY P - 2"); 248 END IF; 249 IF NOT EQUAL (I, 5) AND THEN 250 NOT 251 EQUAL(LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3))) 252 THEN 253 COMMENT ("DISREGARD"); 254 END IF; 255 I := I + 1; 256 EXCEPTION 257 WHEN OTHERS => 258 FAILED ("EXCEPTION RAISED WITHIN " & 259 "PACKAGE P - 2"); 260 I := I + 1; 261 END P; 262 263 BEGIN 264 BEGIN 265 DECLARE 266 AR26 : ACCGENARR (2 .. 6); 267 I : INTEGER := IDENT_INT (5); 268 PACKAGE P2 IS NEW P (AR26, I); 269 BEGIN 270 IF I /= 6 THEN 271 FAILED ("INCORRECT RESULT - " & 272 "PACKAGE P2"); 273 END IF; 274 EXCEPTION 275 WHEN OTHERS => 276 FAILED ("EXCEPTION RAISED TOO LATE - " & 277 "PACKAGE P2 - 1"); 278 END; 279 EXCEPTION 280 WHEN OTHERS => 281 FAILED ("EXCEPTION RAISED AT INSTANTIATION " & 282 "OF PACKAGE P2 WITH NULL ACCESS " & 283 "VALUE"); 284 END; 285 286 BEGIN 287 DECLARE 288 AR26 : ACCGENARR 289 (IDENT_INT (2) .. IDENT_INT (6)) := 290 NEW GENARR'(1,2,3,4,5); 291 I : INTEGER := IDENT_INT (0); 292 PACKAGE P2 IS NEW P (AR26, I); 293 BEGIN 294 FAILED ("NO EXCEPTION RAISED BY " & 295 "INSTANTIATION OF PACKAGE P2"); 296 EXCEPTION 297 WHEN OTHERS => 298 FAILED ("EXCEPTION RAISED TOO LATE - " & 299 "PACKAGE P2 - 2"); 300 END; 301 EXCEPTION 302 WHEN CONSTRAINT_ERROR => 303 NULL; 304 WHEN OTHERS => 305 FAILED ("WRONG EXCEPTION RAISED AT " & 306 "INSTANTIATION OF PACKAGE P2"); 307 END; 308 END GEN; 309 310 PACKAGE NEWGEN IS NEW GEN (ARR); 311 312 BEGIN 313 BEGIN 314 DECLARE 315 I : INTEGER := IDENT_INT (5); 316 AR26 : ACCARR (IDENT_INT (2) .. IDENT_INT (6)); 317 FUNCTION F2 IS NEW F (AR26); 318 BEGIN 319 I := F2 (I); 320 IF I /= 6 THEN 321 FAILED ("INCORRECT RESULT RETURNED BY " & 322 "FUNCTION F2"); 323 END IF; 324 EXCEPTION 325 WHEN OTHERS => 326 FAILED ("EXCEPTION RAISED AT CALL TO " & 327 "FUNCTION F2 - 1"); 328 END; 329 EXCEPTION 330 WHEN OTHERS => 331 FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " & 332 "FUNCTION F2 WITH NULL ACCESS VALUE"); 333 END; 334 335 BEGIN 336 DECLARE 337 I : INTEGER := IDENT_INT (0); 338 AR26 : ACCARR (2 .. 6) := NEW ARR'(1,2,3,4,5); 339 FUNCTION F2 IS NEW F (AR26); 340 BEGIN 341 FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " & 342 "OF FUNCTION F2"); 343 I := F2 (I); 344 EXCEPTION 345 WHEN OTHERS => 346 FAILED ("EXCEPTION RAISED AT CALL TO " & 347 "FUNCTION F2 - 2"); 348 END; 349 EXCEPTION 350 WHEN CONSTRAINT_ERROR => 351 NULL; 352 WHEN OTHERS => 353 FAILED ("WRONG EXCEPTION RAISED AT " & 354 "INSTANTIATION OF FUNCTION F2"); 355 END; 356 END; 357 RESULT; 358END CC3128A; 359