1-- C37213J.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, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN 27-- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE 28-- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN 29-- OBJECT OR A SUBTYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS 30-- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: 31-- 1) ONLY IN AN OBJECT DECLARATION, AND 32-- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT 33-- IN THE SUBTYPE. 34 35-- HISTORY: 36-- JBG 10/17/86 CREATED ORIGINAL TEST. 37-- VCL 10/23/87 MODIFIED THIS HEADER; SEPARATED THIS TEST INTO 38-- 3 NEW TESTS (J,K,L); CHANGED THE AGGREGATE FOR 39-- THE PARAMETER 'VALUE' IN THE CALL OF PROCEDURE 40-- 'SUBTYPE_CHK1'; MOVED THE CALL TO REPORT.TEST 41-- SO THAT IT COMES BEFORE ANY DECLARATIONS; ADDED 42-- A SEQUENCE COUNTER TO IDENTIFY WHICH SUBTEST 43-- DECLARATION PART RAISES CONSTRAINT_ERROR. 44-- VCL 03/28/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY 45-- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL 46-- PARAMETERS TO THE GENERIC UNITS AND THE 47-- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE 48-- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE 49-- ARE TOGETHER. 50 51WITH REPORT; USE REPORT; 52PROCEDURE C37213J IS 53BEGIN 54 TEST ("C37213J", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & 55 "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & 56 "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & 57 "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & 58 "USED AS THE ACTUAL PARAMETER TO A GENERIC " & 59 "FORMAL TYPE USED TO DECLARE AN OBJECT OR A " & 60 "SUBTYPE"); 61 62 DECLARE 63 SUBTYPE SM IS INTEGER RANGE 1..10; 64 TYPE REC (D1, D2 : SM) IS 65 RECORD NULL; END RECORD; 66 TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; 67 68 SEQUENCE_NUMBER : INTEGER; 69 70 GENERIC 71 TYPE CONS IS PRIVATE; 72 OBJ_XCP : BOOLEAN; 73 TAG : STRING; 74 PACKAGE OBJ_CHK IS END OBJ_CHK; 75 76 GENERIC 77 TYPE CONS IS PRIVATE; 78 PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN; 79 TAG : STRING); 80 81 PACKAGE BODY OBJ_CHK IS 82 BEGIN -- DECLARE AN OBJECT OF THE FORMAL TYPE. 83 DECLARE 84 X : CONS; 85 86 FUNCTION VALUE RETURN CONS IS 87 BEGIN 88 IF EQUAL (3,3) THEN 89 RETURN X; 90 ELSE 91 RETURN X; 92 END IF; 93 END VALUE; 94 BEGIN 95 IF OBJ_XCP THEN 96 FAILED ("NO CHECK DURING DECLARATION " & 97 "OF OBJECT OF TYPE CONS - " & TAG); 98 ELSIF X /= VALUE THEN 99 FAILED ("INCORRECT VALUE FOR OBJECT OF " & 100 "TYPE CONS - " & TAG); 101 END IF; 102 END; 103 EXCEPTION 104 WHEN CONSTRAINT_ERROR => 105 IF NOT OBJ_XCP THEN 106 FAILED ("IMPROPER CONSTRAINT CHECKED " & 107 "DURING DECLARATION OF OBJECT " & 108 "OF TYPE CONS - " & TAG); 109 END IF; 110 END OBJ_CHK; 111 112 PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN; 113 TAG : STRING) IS 114 BEGIN -- DECLARE A SUBTYPE OF THE FORMAL TYPE. 115 DECLARE 116 SUBTYPE SCONS IS CONS; 117 BEGIN 118 DECLARE 119 X : SCONS; 120 121 FUNCTION VALUE RETURN SCONS IS 122 BEGIN 123 IF EQUAL (5, 5) THEN 124 RETURN X; 125 ELSE 126 RETURN X; 127 END IF; 128 END VALUE; 129 BEGIN 130 IF OBJ_XCP THEN 131 FAILED ("NO CHECK DURING DECLARATION " & 132 "OF OBJECT OF SUBTYPE SCONS - " & 133 TAG); 134 ELSIF X /= VALUE THEN 135 FAILED ("INCORRECT VALUE FOR OBJECT " & 136 "OF SUBTYPE SCONS - " & TAG); 137 END IF; 138 END; 139 EXCEPTION 140 WHEN CONSTRAINT_ERROR => 141 IF NOT OBJ_XCP THEN 142 FAILED ("IMPROPER CONSTRAINT CHECKED " & 143 "DURING DECLARATION OF OBJECT " & 144 "OF SUBTYPE SCONS - " & TAG); 145 END IF; 146 END; 147 EXCEPTION 148 WHEN CONSTRAINT_ERROR => 149 FAILED ("CONSTRAINT IMPROPERLY CHECKED " & 150 "DURING SUBTYPE DECLARATION - " & TAG); 151 END SUBTYP_CHK; 152 BEGIN 153 SEQUENCE_NUMBER := 1; 154 DECLARE 155 TYPE REC_DEF (D3 : INTEGER := 1) IS 156 RECORD 157 C1 : REC (D3, 0); 158 END RECORD; 159 160 PACKAGE PACK1 IS NEW OBJ_CHK (REC_DEF, 161 OBJ_XCP => TRUE, 162 TAG => "PACK1"); 163 164 PROCEDURE PROC1 IS NEW SUBTYP_CHK (REC_DEF); 165 BEGIN 166 PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); 167 END; 168 169 SEQUENCE_NUMBER := 2; 170 DECLARE 171 TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS 172 RECORD 173 C1 : MY_ARR (0..D3); 174 END RECORD; 175 176 PACKAGE PACK2 IS NEW OBJ_CHK (ARR_DEF, 177 OBJ_XCP => TRUE, 178 TAG => "PACK2"); 179 180 PROCEDURE PROC2 IS NEW SUBTYP_CHK (ARR_DEF); 181 BEGIN 182 PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); 183 END; 184 185 186 SEQUENCE_NUMBER := 3; 187 DECLARE 188 TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS 189 RECORD 190 CASE D3 IS 191 WHEN -5..10 => 192 C1 : REC (D3, IDENT_INT(11)); 193 WHEN OTHERS => 194 C2 : INTEGER := IDENT_INT(5); 195 END CASE; 196 END RECORD; 197 198 PACKAGE PACK3 IS NEW OBJ_CHK (VAR_REC_DEF1, 199 OBJ_XCP => TRUE, 200 TAG => "PACK3"); 201 202 PROCEDURE PROC3 IS NEW SUBTYP_CHK (VAR_REC_DEF1); 203 BEGIN 204 PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); 205 END; 206 207 SEQUENCE_NUMBER := 4; 208 DECLARE 209 TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS 210 RECORD 211 CASE D3 IS 212 WHEN -5..10 => 213 C1 : REC (D3, IDENT_INT(11)); 214 WHEN OTHERS => 215 C2 : INTEGER := IDENT_INT(5); 216 END CASE; 217 END RECORD; 218 219 PACKAGE PACK4 IS NEW OBJ_CHK (VAR_REC_DEF6, 220 OBJ_XCP => FALSE, 221 TAG => "PACK4"); 222 223 PROCEDURE PROC4 IS NEW SUBTYP_CHK (VAR_REC_DEF6); 224 BEGIN 225 PROC4 (OBJ_XCP => FALSE,TAG => "PROC4"); 226 END; 227 228 SEQUENCE_NUMBER := 5; 229 DECLARE 230 TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS 231 RECORD 232 CASE D3 IS 233 WHEN -5..10 => 234 C1 : REC (D3, IDENT_INT(11)); 235 WHEN OTHERS => 236 C2 : INTEGER := IDENT_INT(5); 237 END CASE; 238 END RECORD; 239 240 PACKAGE PACK5 IS NEW OBJ_CHK (VAR_REC_DEF11, 241 OBJ_XCP => FALSE, 242 TAG => "PACK5"); 243 244 PROCEDURE PROC5 IS NEW SUBTYP_CHK (VAR_REC_DEF11); 245 BEGIN 246 PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); 247 END; 248 249 SEQUENCE_NUMBER := 6; 250 DECLARE 251 TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS 252 RECORD 253 CASE D3 IS 254 WHEN -5..10 => 255 C1 : MY_ARR(D3..IDENT_INT(11)); 256 WHEN OTHERS => 257 C2 : INTEGER := IDENT_INT(5); 258 END CASE; 259 END RECORD; 260 261 PACKAGE PACK6 IS NEW OBJ_CHK (VAR_ARR_DEF1, 262 OBJ_XCP => TRUE, 263 TAG => "PACK6"); 264 265 PROCEDURE PROC6 IS NEW SUBTYP_CHK (VAR_ARR_DEF1); 266 BEGIN 267 PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); 268 END; 269 270 SEQUENCE_NUMBER := 7; 271 DECLARE 272 TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS 273 RECORD 274 CASE D3 IS 275 WHEN -5..10 => 276 C1 : MY_ARR(D3..IDENT_INT(11)); 277 WHEN OTHERS => 278 C2 : INTEGER := IDENT_INT(5); 279 END CASE; 280 END RECORD; 281 282 PACKAGE PACK7 IS NEW OBJ_CHK (VAR_ARR_DEF6, 283 OBJ_XCP => FALSE, 284 TAG => "PACK7"); 285 286 PROCEDURE PROC7 IS NEW SUBTYP_CHK (VAR_ARR_DEF6); 287 BEGIN 288 PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); 289 END; 290 291 SEQUENCE_NUMBER := 8; 292 DECLARE 293 TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS 294 RECORD 295 CASE D3 IS 296 WHEN -5..10 => 297 C1 : MY_ARR(D3..IDENT_INT(11)); 298 WHEN OTHERS => 299 C2 : INTEGER := IDENT_INT(5); 300 END CASE; 301 END RECORD; 302 303 PACKAGE PACK8 IS NEW OBJ_CHK (VAR_ARR_DEF11, 304 OBJ_XCP => FALSE, 305 TAG => "PACK8"); 306 307 PROCEDURE PROC8 IS NEW SUBTYP_CHK (VAR_ARR_DEF11); 308 BEGIN 309 PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); 310 END; 311 312 EXCEPTION 313 WHEN OTHERS => 314 FAILED ("EXCEPTION RAISED DURING DECLARATION / " & 315 "INSTANTIATION ELABORATION - " & 316 INTEGER'IMAGE(SEQUENCE_NUMBER)); 317 END; 318 319 RESULT; 320END C37213J; 321