1-- C34006J.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED 27-- (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH 28-- A LIMITED COMPONENT TYPE. 29 30-- HISTORY: 31-- JRK 08/25/87 CREATED ORIGINAL TEST. 32-- VCL 06/28/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE 33-- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE 34-- SIZES. 35-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. 36 37WITH SYSTEM; USE SYSTEM; 38WITH REPORT; USE REPORT; 39 40PROCEDURE C34006J IS 41 42 PACKAGE PKG_L IS 43 44 TYPE LP IS LIMITED PRIVATE; 45 46 FUNCTION CREATE (X : INTEGER) RETURN LP; 47 48 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; 49 50 PROCEDURE ASSIGN (X : OUT LP; Y : LP); 51 52 C4 : CONSTANT LP; 53 C5 : CONSTANT LP; 54 55 PRIVATE 56 57 TYPE LP IS NEW INTEGER; 58 59 C4 : CONSTANT LP := 4; 60 C5 : CONSTANT LP := 5; 61 62 END PKG_L; 63 64 USE PKG_L; 65 66 SUBTYPE COMPONENT IS LP; 67 68 PACKAGE PKG_P IS 69 70 MAX_LEN : CONSTANT := 10; 71 72 SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; 73 74 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS 75 RECORD 76 I : INTEGER := 2; 77 CASE B IS 78 WHEN TRUE => 79 S : STRING (1 .. L) := (1 .. L => 'A'); 80 C : COMPONENT; 81 WHEN FALSE => 82 F : FLOAT := 5.0; 83 END CASE; 84 END RECORD; 85 86 FUNCTION CREATE ( B : BOOLEAN; 87 L : LENGTH; 88 I : INTEGER; 89 S : STRING; 90 C : COMPONENT; 91 F : FLOAT; 92 X : PARENT -- TO RESOLVE OVERLOADING. 93 ) RETURN PARENT; 94 95 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; 96 97 FUNCTION AGGR ( B : BOOLEAN; 98 L : LENGTH; 99 I : INTEGER; 100 S : STRING; 101 C : COMPONENT 102 ) RETURN PARENT; 103 104 FUNCTION AGGR ( B : BOOLEAN; 105 L : LENGTH; 106 I : INTEGER; 107 F : FLOAT 108 ) RETURN PARENT; 109 110 END PKG_P; 111 112 USE PKG_P; 113 114 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); 115 116 X : T; 117 W : PARENT; 118 B : BOOLEAN := FALSE; 119 120 PROCEDURE A (X : ADDRESS) IS 121 BEGIN 122 B := IDENT_BOOL (TRUE); 123 END A; 124 125 PACKAGE BODY PKG_L IS 126 127 FUNCTION CREATE (X : INTEGER) RETURN LP IS 128 BEGIN 129 RETURN LP (IDENT_INT (X)); 130 END CREATE; 131 132 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS 133 BEGIN 134 RETURN X = Y; 135 END EQUAL; 136 137 PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS 138 BEGIN 139 X := Y; 140 END ASSIGN; 141 142 END PKG_L; 143 144 PACKAGE BODY PKG_P IS 145 146 FUNCTION CREATE 147 ( B : BOOLEAN; 148 L : LENGTH; 149 I : INTEGER; 150 S : STRING; 151 C : COMPONENT; 152 F : FLOAT; 153 X : PARENT 154 ) RETURN PARENT 155 IS 156 A : PARENT (B, L); 157 BEGIN 158 A.I := I; 159 CASE B IS 160 WHEN TRUE => 161 A.S := S; 162 ASSIGN (A.C, C); 163 WHEN FALSE => 164 A.F := F; 165 END CASE; 166 RETURN A; 167 END CREATE; 168 169 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS 170 BEGIN 171 IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN 172 RETURN FALSE; 173 END IF; 174 CASE X.B IS 175 WHEN TRUE => 176 RETURN X.S = Y.S AND EQUAL (X.C, Y.C); 177 WHEN FALSE => 178 RETURN X.F = Y.F; 179 END CASE; 180 END EQUAL; 181 182 FUNCTION AGGR 183 ( B : BOOLEAN; 184 L : LENGTH; 185 I : INTEGER; 186 S : STRING; 187 C : COMPONENT 188 ) RETURN PARENT 189 IS 190 RESULT : PARENT (B, L); 191 BEGIN 192 RESULT.I := I; 193 RESULT.S := S; 194 ASSIGN (RESULT.C, C); 195 RETURN RESULT; 196 END AGGR; 197 198 FUNCTION AGGR 199 ( B : BOOLEAN; 200 L : LENGTH; 201 I : INTEGER; 202 F : FLOAT 203 ) RETURN PARENT 204 IS 205 RESULT : PARENT (B, L); 206 BEGIN 207 RESULT.I := I; 208 RESULT.F := F; 209 RETURN RESULT; 210 END AGGR; 211 212 END PKG_P; 213 214BEGIN 215 TEST ("C34006J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & 216 "ARE DECLARED (IMPLICITLY) FOR DERIVED " & 217 "RECORD TYPES WITH DISCRIMINANTS AND WITH A " & 218 "LIMITED COMPONENT TYPE"); 219 220 X.I := IDENT_INT (1); 221 X.S := IDENT_STR ("ABC"); 222 ASSIGN (X.C, CREATE (4)); 223 224 W.I := IDENT_INT (1); 225 W.S := IDENT_STR ("ABC"); 226 ASSIGN (W.C, CREATE (4)); 227 228 IF NOT EQUAL (T'(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN 229 FAILED ("INCORRECT QUALIFICATION"); 230 END IF; 231 232 IF NOT EQUAL (T(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN 233 FAILED ("INCORRECT SELF CONVERSION"); 234 END IF; 235 236 IF NOT EQUAL (T(W), AGGR (TRUE, 3, 1, "ABC", C4)) THEN 237 FAILED ("INCORRECT CONVERSION FROM PARENT"); 238 END IF; 239 240 IF NOT EQUAL (PARENT(X), AGGR (TRUE, 3, 1, "ABC", C4)) OR 241 NOT EQUAL (PARENT(CREATE (FALSE, 2, 3, "XX", C5, 6.0, X)), 242 AGGR (FALSE, 2, 3, 6.0)) THEN 243 FAILED ("INCORRECT CONVERSION TO PARENT"); 244 END IF; 245 246 IF X.B /= TRUE OR X.L /= 3 OR 247 CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).B /= FALSE OR 248 CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).L /= 2 THEN 249 FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); 250 END IF; 251 252 IF X.I /= 1 OR X.S /= "ABC" OR NOT EQUAL (X.C, C4) OR 253 CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).I /= 3 OR 254 CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).F /= 6.0 THEN 255 FAILED ("INCORRECT SELECTION (VALUE)"); 256 END IF; 257 258 X.I := IDENT_INT (7); 259 X.S := IDENT_STR ("XYZ"); 260 IF NOT EQUAL (X, AGGR (TRUE, 3, 7, "XYZ", C4)) THEN 261 FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); 262 END IF; 263 264 X.I := IDENT_INT (1); 265 X.S := IDENT_STR ("ABC"); 266 IF NOT (X IN T) OR AGGR (FALSE, 2, 3, 6.0) IN T THEN 267 FAILED ("INCORRECT ""IN"""); 268 END IF; 269 270 IF X NOT IN T OR NOT (AGGR (FALSE, 2, 3, 6.0) NOT IN T) THEN 271 FAILED ("INCORRECT ""NOT IN"""); 272 END IF; 273 274 B := FALSE; 275 A (X'ADDRESS); 276 IF NOT B THEN 277 FAILED ("INCORRECT 'ADDRESS"); 278 END IF; 279 280 IF NOT X'CONSTRAINED THEN 281 FAILED ("INCORRECT 'CONSTRAINED"); 282 END IF; 283 284 IF X.C'FIRST_BIT < 0 THEN 285 FAILED ("INCORRECT 'FIRST_BIT"); 286 END IF; 287 288 IF X.C'LAST_BIT < 0 OR 289 X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN 290 FAILED ("INCORRECT 'LAST_BIT"); 291 END IF; 292 293 IF X.C'POSITION < 0 THEN 294 FAILED ("INCORRECT 'POSITION"); 295 END IF; 296 297 IF X'SIZE < T'SIZE THEN 298 COMMENT ("X'SIZE < T'SIZE"); 299 ELSIF X'SIZE = T'SIZE THEN 300 COMMENT ("X'SIZE = T'SIZE"); 301 ELSE 302 COMMENT ("X'SIZE > T'SIZE"); 303 END IF; 304 305 RESULT; 306EXCEPTION 307 WHEN OTHERS => 308 FAILED ("UNEXPECTED EXCEPTION RAISED WHILE CHECKING BASIC " & 309 "OPERATIONS"); 310 RESULT; 311END C34006J; 312