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