1-- C34006G.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 WITHOUT DISCRIMINANTS AND 28-- WITH A LIMITED COMPONENT TYPE. 29 30-- HISTORY: 31-- JRK 08/24/87 CREATED ORIGINAL TEST. 32-- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. 33-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. 34 35WITH SYSTEM; USE SYSTEM; 36WITH REPORT; USE REPORT; 37 38PROCEDURE C34006G IS 39 40 PACKAGE PKG_L IS 41 42 TYPE LP IS LIMITED PRIVATE; 43 44 FUNCTION CREATE (X : INTEGER) RETURN LP; 45 46 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; 47 48 PROCEDURE ASSIGN (X : OUT LP; Y : LP); 49 50 C1 : CONSTANT LP; 51 52 PRIVATE 53 54 TYPE LP IS NEW INTEGER; 55 56 C1 : CONSTANT LP := 1; 57 58 END PKG_L; 59 60 USE PKG_L; 61 62 SUBTYPE COMPONENT IS LP; 63 64 PACKAGE PKG_P IS 65 66 TYPE PARENT IS 67 RECORD 68 C : COMPONENT; 69 B : BOOLEAN := TRUE; 70 END RECORD; 71 72 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; 73 74 FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT; 75 76 END PKG_P; 77 78 USE PKG_P; 79 80 TYPE T IS NEW PARENT; 81 82 X : T; 83 W : PARENT; 84 B : BOOLEAN := FALSE; 85 86 PROCEDURE A (X : ADDRESS) IS 87 BEGIN 88 B := IDENT_BOOL (TRUE); 89 END A; 90 91 PACKAGE BODY PKG_L IS 92 93 FUNCTION CREATE (X : INTEGER) RETURN LP IS 94 BEGIN 95 RETURN LP (IDENT_INT (X)); 96 END CREATE; 97 98 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS 99 BEGIN 100 RETURN X = Y; 101 END EQUAL; 102 103 PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS 104 BEGIN 105 X := Y; 106 END ASSIGN; 107 108 END PKG_L; 109 110 PACKAGE BODY PKG_P IS 111 112 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS 113 BEGIN 114 RETURN EQUAL (X.C, Y.C) AND X.B = Y.B; 115 END EQUAL; 116 117 FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT IS 118 RESULT : PARENT; 119 BEGIN 120 ASSIGN (RESULT.C, C); 121 RESULT.B := B; 122 RETURN RESULT; 123 END AGGR; 124 125 END PKG_P; 126 127BEGIN 128 TEST ("C34006G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & 129 "ARE DECLARED (IMPLICITLY) FOR DERIVED " & 130 "RECORD TYPES WITHOUT DISCRIMINANTS AND WITH A " & 131 "LIMITED COMPONENT TYPE"); 132 133 ASSIGN (X.C, CREATE (1)); 134 X.B := IDENT_BOOL (TRUE); 135 136 ASSIGN (W.C, CREATE (1)); 137 W.B := IDENT_BOOL (TRUE); 138 139 IF NOT EQUAL (T'(X), AGGR (C1, TRUE)) THEN 140 FAILED ("INCORRECT QUALIFICATION"); 141 END IF; 142 143 IF NOT EQUAL (T (X), AGGR (C1, TRUE)) THEN 144 FAILED ("INCORRECT SELF CONVERSION"); 145 END IF; 146 147 IF NOT EQUAL (T (W), AGGR (C1, TRUE)) THEN 148 FAILED ("INCORRECT CONVERSION FROM PARENT"); 149 END IF; 150 151 IF NOT EQUAL (PARENT (X), AGGR (C1, TRUE)) THEN 152 FAILED ("INCORRECT CONVERSION TO PARENT"); 153 END IF; 154 155 IF NOT EQUAL (X.C, C1) OR X.B /= TRUE THEN 156 FAILED ("INCORRECT SELECTION (VALUE)"); 157 END IF; 158 159 X.B := IDENT_BOOL (FALSE); 160 IF NOT EQUAL (X, AGGR (C1, FALSE)) THEN 161 FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); 162 END IF; 163 164 X.B := IDENT_BOOL (TRUE); 165 IF NOT (X IN T) THEN 166 FAILED ("INCORRECT ""IN"""); 167 END IF; 168 169 IF X NOT IN T THEN 170 FAILED ("INCORRECT ""NOT IN"""); 171 END IF; 172 173 B := FALSE; 174 A (X'ADDRESS); 175 IF NOT B THEN 176 FAILED ("INCORRECT 'ADDRESS"); 177 END IF; 178 179 IF X.C'FIRST_BIT < 0 THEN 180 FAILED ("INCORRECT 'FIRST_BIT"); 181 END IF; 182 183 IF X.C'LAST_BIT < 0 OR 184 X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN 185 FAILED ("INCORRECT 'LAST_BIT"); 186 END IF; 187 188 IF X.C'POSITION < 0 THEN 189 FAILED ("INCORRECT 'POSITION"); 190 END IF; 191 192 IF X'SIZE < T'SIZE OR 193 X.C'SIZE < COMPONENT'SIZE OR 194 X.B'SIZE < BOOLEAN'SIZE THEN 195 FAILED ("INCORRECT OBJECT'SIZE"); 196 END IF; 197 198 RESULT; 199END C34006G; 200