1-- C34006L.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 RECORD TYPES WITH DISCRIMINANTS AND WITH A LIMITED 27-- COMPONENT TYPE: 28 29-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT 30-- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION 31-- IS CONSTRAINED. 32 33-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS 34-- ALSO IMPOSED ON THE DERIVED SUBTYPE. 35 36-- HISTORY: 37-- JRK 08/26/87 CREATED ORIGINAL TEST. 38 39WITH REPORT; USE REPORT; 40 41PROCEDURE C34006L IS 42 43 PACKAGE PKG_L IS 44 45 TYPE LP IS LIMITED PRIVATE; 46 47 FUNCTION CREATE (X : INTEGER) RETURN LP; 48 49 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; 50 51 PROCEDURE ASSIGN (X : OUT LP; Y : LP); 52 53 C2 : CONSTANT LP; 54 C4 : CONSTANT LP; 55 C5 : CONSTANT LP; 56 C6 : CONSTANT LP; 57 58 PRIVATE 59 60 TYPE LP IS NEW INTEGER; 61 62 C2 : CONSTANT LP := 2; 63 C4 : CONSTANT LP := 4; 64 C5 : CONSTANT LP := 5; 65 C6 : CONSTANT LP := 6; 66 67 END PKG_L; 68 69 USE PKG_L; 70 71 SUBTYPE COMPONENT IS LP; 72 73 PACKAGE PKG_P IS 74 75 MAX_LEN : CONSTANT := 10; 76 77 SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; 78 79 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS 80 RECORD 81 I : INTEGER := 2; 82 CASE B IS 83 WHEN TRUE => 84 S : STRING (1 .. L) := (1 .. L => 'A'); 85 C : COMPONENT; 86 WHEN FALSE => 87 F : FLOAT := 5.0; 88 END CASE; 89 END RECORD; 90 91 FUNCTION CREATE ( B : BOOLEAN; 92 L : LENGTH; 93 I : INTEGER; 94 S : STRING; 95 C : COMPONENT; 96 F : FLOAT; 97 X : PARENT -- TO RESOLVE OVERLOADING. 98 ) RETURN PARENT; 99 100 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; 101 102 FUNCTION AGGR ( B : BOOLEAN; 103 L : LENGTH; 104 I : INTEGER; 105 S : STRING; 106 C : COMPONENT 107 ) RETURN PARENT; 108 109 FUNCTION AGGR ( B : BOOLEAN; 110 L : LENGTH; 111 I : INTEGER; 112 F : FLOAT 113 ) RETURN PARENT; 114 115 END PKG_P; 116 117 USE PKG_P; 118 119 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); 120 121 SUBTYPE SUBPARENT IS PARENT (TRUE, 3); 122 123 TYPE S IS NEW SUBPARENT; 124 125 X : T; 126 Y : S; 127 128 PACKAGE BODY PKG_L IS 129 130 FUNCTION CREATE (X : INTEGER) RETURN LP IS 131 BEGIN 132 RETURN LP (IDENT_INT (X)); 133 END CREATE; 134 135 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS 136 BEGIN 137 RETURN X = Y; 138 END EQUAL; 139 140 PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS 141 BEGIN 142 X := Y; 143 END ASSIGN; 144 145 END PKG_L; 146 147 PACKAGE BODY PKG_P IS 148 149 FUNCTION CREATE 150 ( B : BOOLEAN; 151 L : LENGTH; 152 I : INTEGER; 153 S : STRING; 154 C : COMPONENT; 155 F : FLOAT; 156 X : PARENT 157 ) RETURN PARENT 158 IS 159 A : PARENT (B, L); 160 BEGIN 161 A.I := I; 162 CASE B IS 163 WHEN TRUE => 164 A.S := S; 165 ASSIGN (A.C, C); 166 WHEN FALSE => 167 A.F := F; 168 END CASE; 169 RETURN A; 170 END CREATE; 171 172 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS 173 BEGIN 174 IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN 175 RETURN FALSE; 176 END IF; 177 CASE X.B IS 178 WHEN TRUE => 179 RETURN X.S = Y.S AND EQUAL (X.C, Y.C); 180 WHEN FALSE => 181 RETURN X.F = Y.F; 182 END CASE; 183 END EQUAL; 184 185 FUNCTION AGGR 186 ( B : BOOLEAN; 187 L : LENGTH; 188 I : INTEGER; 189 S : STRING; 190 C : COMPONENT 191 ) RETURN PARENT 192 IS 193 RESULT : PARENT (B, L); 194 BEGIN 195 RESULT.I := I; 196 RESULT.S := S; 197 ASSIGN (RESULT.C, C); 198 RETURN RESULT; 199 END AGGR; 200 201 FUNCTION AGGR 202 ( B : BOOLEAN; 203 L : LENGTH; 204 I : INTEGER; 205 F : FLOAT 206 ) RETURN PARENT 207 IS 208 RESULT : PARENT (B, L); 209 BEGIN 210 RESULT.I := I; 211 RESULT.F := F; 212 RETURN RESULT; 213 END AGGR; 214 215 END PKG_P; 216 217 PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS 218 BEGIN 219 X.I := Y.I; 220 X.S := Y.S; 221 ASSIGN (X.C, Y.C); 222 END ASSIGN; 223 224 PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS 225 BEGIN 226 X.I := Y.I; 227 X.S := Y.S; 228 ASSIGN (X.C, Y.C); 229 END ASSIGN; 230 231BEGIN 232 TEST ("C34006L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 233 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 234 "WHEN THE DERIVED TYPE DEFINITION IS " & 235 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 236 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 237 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 238 "RECORD TYPES WITH DISCRIMINANTS AND WITH A " & 239 "LIMITED COMPONENT TYPE"); 240 241 ASSIGN (X.C, CREATE (2)); 242 ASSIGN (Y.C, C2); 243 244 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 245 246 IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X), 247 AGGR (FALSE, 2, 3, 6.0)) OR 248 NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y), 249 AGGR (FALSE, 2, 3, 6.0)) THEN 250 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); 251 END IF; 252 253 IF CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X) IN T OR 254 CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y) IN S THEN 255 FAILED ("INCORRECT ""IN"""); 256 END IF; 257 258 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 259 260 IF X.B /= TRUE OR X.L /= 3 OR 261 Y.B /= TRUE OR Y.L /= 3 THEN 262 FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); 263 END IF; 264 265 IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN 266 FAILED ("INCORRECT 'CONSTRAINED"); 267 END IF; 268 269 BEGIN 270 ASSIGN (X, AGGR (TRUE, 3, 1, "ABC", C4)); 271 ASSIGN (Y, AGGR (TRUE, 3, 1, "ABC", C4)); 272 IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. 273 FAILED ("INCORRECT CONVERSION TO PARENT"); 274 END IF; 275 EXCEPTION 276 WHEN OTHERS => 277 FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); 278 END; 279 280 BEGIN 281 ASSIGN (X, AGGR (FALSE, 3, 2, 6.0)); 282 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 283 "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); 284 IF EQUAL (X, AGGR (FALSE, 3, 2, 6.0)) THEN -- USE X. 285 COMMENT ("X ALTERED -- " & 286 "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); 287 END IF; 288 EXCEPTION 289 WHEN CONSTRAINT_ERROR => 290 NULL; 291 WHEN OTHERS => 292 FAILED ("WRONG EXCEPTION RAISED -- " & 293 "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); 294 END; 295 296 BEGIN 297 ASSIGN (X, AGGR (TRUE, 4, 2, "ZZZZ", C6)); 298 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 299 "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); 300 IF EQUAL (X, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN -- USE X. 301 COMMENT ("X ALTERED -- " & 302 "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); 303 END IF; 304 EXCEPTION 305 WHEN CONSTRAINT_ERROR => 306 NULL; 307 WHEN OTHERS => 308 FAILED ("WRONG EXCEPTION RAISED -- " & 309 "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); 310 END; 311 312 BEGIN 313 ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0)); 314 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 315 "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); 316 IF EQUAL (Y, AGGR (FALSE, 3, 2, 6.0)) THEN -- USE Y. 317 COMMENT ("Y ALTERED -- " & 318 "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); 319 END IF; 320 EXCEPTION 321 WHEN CONSTRAINT_ERROR => 322 NULL; 323 WHEN OTHERS => 324 FAILED ("WRONG EXCEPTION RAISED -- " & 325 "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); 326 END; 327 328 BEGIN 329 ASSIGN (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6)); 330 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 331 "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); 332 IF EQUAL (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN -- USE Y. 333 COMMENT ("Y ALTERED -- " & 334 "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); 335 END IF; 336 EXCEPTION 337 WHEN CONSTRAINT_ERROR => 338 NULL; 339 WHEN OTHERS => 340 FAILED ("WRONG EXCEPTION RAISED -- " & 341 "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); 342 END; 343 344 RESULT; 345END C34006L; 346