1-- C37213D.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 IF 26-- AN INDEX CONSTRAINT 27-- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE 28-- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS 29-- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS: 30-- 31-- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT 32-- DECLARATION. 33 34-- JBG 10/17/86 35 36WITH REPORT; USE REPORT; 37PROCEDURE C37213D IS 38 39 SUBTYPE SM IS INTEGER RANGE 1..10; 40 41 TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; 42 43 F1_CONS : INTEGER := 2; 44 45 FUNCTION CHK ( 46 CONS : INTEGER; 47 VALUE : INTEGER; 48 MESSAGE : STRING) RETURN BOOLEAN IS 49 BEGIN 50 IF CONS /= VALUE THEN 51 FAILED (MESSAGE & ": CONS IS " & 52 INTEGER'IMAGE(CONS)); 53 END IF; 54 RETURN TRUE; 55 END CHK; 56 57 FUNCTION F1 RETURN INTEGER IS 58 BEGIN 59 F1_CONS := F1_CONS - IDENT_INT(1); 60 RETURN F1_CONS; 61 END F1; 62 63BEGIN 64 TEST ("C37213D", "CHECK EVALUATION OF INDEX BOUNDS " & 65 "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & 66 "AND DISCRIMINANTS HAVE DEFAULTS"); 67 68-- CASE B 69 70 DECLARE 71 TYPE CONS (D3 : INTEGER := 1) IS 72 RECORD 73 C1 : MY_ARR (F1..D3); -- F1 EVALUATED. 74 END RECORD; 75 CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); 76 X : CONS; -- F1 NOT EVALUATED AGAIN 77 Y : CONS; -- F1 NOT EVALUATED AGAIN 78 CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); 79 BEGIN 80 IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN 81 FAILED ("INDEX BOUNDS NOT CORRECT"); 82 END IF; 83 END; 84 85 F1_CONS := 12; 86 87 DECLARE 88 TYPE CONS (D3 : INTEGER := 1) IS 89 RECORD 90 C1 : MY_ARR(D3..F1); 91 END RECORD; 92 BEGIN 93 BEGIN 94 DECLARE 95 X : CONS; 96 BEGIN 97 FAILED ("INDEX CHECK NOT PERFORMED - 1"); 98 IF X /= (1, (1, 1)) THEN 99 COMMENT ("SHOULDN'T GET HERE"); 100 END IF; 101 END; 102 EXCEPTION 103 WHEN CONSTRAINT_ERROR => 104 NULL; 105 WHEN OTHERS => 106 FAILED ("UNEXPECTED EXCEPTION - 1"); 107 END; 108 109 BEGIN 110 DECLARE 111 TYPE ACC_CONS IS ACCESS CONS; 112 X : ACC_CONS; 113 BEGIN 114 X := NEW CONS; 115 FAILED ("INDEX CHECK NOT PERFORMED - 2"); 116 BEGIN 117 IF X.ALL /= (1, (1 => 1)) THEN 118 COMMENT ("IRRELEVANT"); 119 END IF; 120 END; 121 EXCEPTION 122 WHEN CONSTRAINT_ERROR => 123 NULL; 124 WHEN OTHERS => 125 FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); 126 END; 127 EXCEPTION 128 WHEN OTHERS => 129 FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); 130 END; 131 132 BEGIN 133 DECLARE 134 SUBTYPE SCONS IS CONS; 135 BEGIN 136 DECLARE 137 X : SCONS; 138 BEGIN 139 FAILED ("INDEX CHECK NOT " & 140 "PERFORMED - 3"); 141 IF X /= (1, (1 => 1)) THEN 142 COMMENT ("IRRELEVANT"); 143 END IF; 144 END; 145 EXCEPTION 146 WHEN CONSTRAINT_ERROR => 147 NULL; 148 WHEN OTHERS => 149 FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); 150 END; 151 EXCEPTION 152 WHEN OTHERS => 153 FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); 154 END; 155 156 BEGIN 157 DECLARE 158 TYPE ARR IS ARRAY (1..5) OF CONS; 159 BEGIN 160 DECLARE 161 X : ARR; 162 BEGIN 163 FAILED ("INDEX CHECK NOT " & 164 "PERFORMED - 4"); 165 IF X /= (1..5 => (1, (1 => 1))) THEN 166 COMMENT ("IRRELEVANT"); 167 END IF; 168 END; 169 EXCEPTION 170 WHEN CONSTRAINT_ERROR => 171 NULL; 172 WHEN OTHERS => 173 FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); 174 END; 175 EXCEPTION 176 WHEN OTHERS => 177 FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); 178 END; 179 180 BEGIN 181 DECLARE 182 TYPE NREC IS 183 RECORD 184 C1 : CONS; 185 END RECORD; 186 BEGIN 187 DECLARE 188 X : NREC; 189 BEGIN 190 FAILED ("INDEX CHECK NOT " & 191 "PERFORMED - 5"); 192 IF X /= (C1 => (1, (1 => 1))) THEN 193 COMMENT ("IRRELEVANT"); 194 END IF; 195 END; 196 EXCEPTION 197 WHEN CONSTRAINT_ERROR => 198 NULL; 199 WHEN OTHERS => 200 FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); 201 END; 202 EXCEPTION 203 WHEN OTHERS => 204 FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); 205 END; 206 207 BEGIN 208 DECLARE 209 TYPE DREC IS NEW CONS; 210 BEGIN 211 DECLARE 212 X : DREC; 213 BEGIN 214 FAILED ("INDEX CHECK NOT " & 215 "PERFORMED - 6"); 216 IF X /= (1, (1 => 1)) THEN 217 COMMENT ("IRRELEVANT"); 218 END IF; 219 END; 220 EXCEPTION 221 WHEN CONSTRAINT_ERROR => 222 NULL; 223 WHEN OTHERS => 224 FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); 225 END; 226 EXCEPTION 227 WHEN OTHERS => 228 FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); 229 END; 230 231 END; 232 233 RESULT; 234 235EXCEPTION 236 WHEN OTHERS => 237 FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); 238 RESULT; 239 240END C37213D; 241