1-- C34009D.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 NON-LIMITED PRIVATE TYPES WITH 28-- DISCRIMINANTS. 29 30-- HISTORY: 31-- JRK 08/31/87 CREATED ORIGINAL TEST. 32-- WMC 03/13/92 REVISED TYPE'SIZE CHECKS. 33-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. 34 35WITH SYSTEM; USE SYSTEM; 36WITH REPORT; USE REPORT; 37 38PROCEDURE C34009D IS 39 40 PACKAGE PKG IS 41 42 MAX_LEN : CONSTANT := 10; 43 44 SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; 45 46 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS PRIVATE; 47 48 FUNCTION CREATE ( B : BOOLEAN; 49 L : LENGTH; 50 I : INTEGER; 51 S : STRING; 52 J : INTEGER; 53 F : FLOAT; 54 X : PARENT -- TO RESOLVE OVERLOADING. 55 ) RETURN PARENT; 56 57 FUNCTION CON ( B : BOOLEAN; 58 L : LENGTH; 59 I : INTEGER; 60 S : STRING; 61 J : INTEGER 62 ) RETURN PARENT; 63 64 FUNCTION CON ( B : BOOLEAN; 65 L : LENGTH; 66 I : INTEGER; 67 F : FLOAT 68 ) RETURN PARENT; 69 70 PRIVATE 71 72 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS 73 RECORD 74 I : INTEGER; 75 CASE B IS 76 WHEN TRUE => 77 S : STRING (1 .. L); 78 J : INTEGER; 79 WHEN FALSE => 80 F : FLOAT := 5.0; 81 END CASE; 82 END RECORD; 83 84 END PKG; 85 86 USE PKG; 87 88 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); 89 90 X : T; 91 W : PARENT; 92 B : BOOLEAN := FALSE; 93 94 PROCEDURE A (X : ADDRESS) IS 95 BEGIN 96 B := IDENT_BOOL (TRUE); 97 END A; 98 99 PACKAGE BODY PKG IS 100 101 FUNCTION CREATE 102 ( B : BOOLEAN; 103 L : LENGTH; 104 I : INTEGER; 105 S : STRING; 106 J : INTEGER; 107 F : FLOAT; 108 X : PARENT 109 ) RETURN PARENT 110 IS 111 BEGIN 112 CASE B IS 113 WHEN TRUE => 114 RETURN (TRUE, L, I, S, J); 115 WHEN FALSE => 116 RETURN (FALSE, L, I, F); 117 END CASE; 118 END CREATE; 119 120 FUNCTION CON 121 ( B : BOOLEAN; 122 L : LENGTH; 123 I : INTEGER; 124 S : STRING; 125 J : INTEGER 126 ) RETURN PARENT 127 IS 128 BEGIN 129 RETURN (TRUE, L, I, S, J); 130 END CON; 131 132 FUNCTION CON 133 ( B : BOOLEAN; 134 L : LENGTH; 135 I : INTEGER; 136 F : FLOAT 137 ) RETURN PARENT 138 IS 139 BEGIN 140 RETURN (FALSE, L, I, F); 141 END CON; 142 143 END PKG; 144 145BEGIN 146 TEST ("C34009D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & 147 "ARE DECLARED (IMPLICITLY) FOR DERIVED " & 148 "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); 149 150 X := CON (TRUE, 3, 2, "AAA", 2); 151 W := CON (TRUE, 3, 2, "AAA", 2); 152 153 IF EQUAL (3, 3) THEN 154 X := CON (TRUE, 3, 1, "ABC", 4); 155 END IF; 156 IF X /= CON (TRUE, 3, 1, "ABC", 4) THEN 157 FAILED ("INCORRECT :="); 158 END IF; 159 160 IF T'(X) /= CON (TRUE, 3, 1, "ABC", 4) THEN 161 FAILED ("INCORRECT QUALIFICATION"); 162 END IF; 163 164 IF T (X) /= CON (TRUE, 3, 1, "ABC", 4) THEN 165 FAILED ("INCORRECT SELF CONVERSION"); 166 END IF; 167 168 IF EQUAL (3, 3) THEN 169 W := CON (TRUE, 3, 1, "ABC", 4); 170 END IF; 171 IF T (W) /= CON (TRUE, 3, 1, "ABC", 4) THEN 172 FAILED ("INCORRECT CONVERSION FROM PARENT"); 173 END IF; 174 175 IF PARENT (X) /= CON (TRUE, 3, 1, "ABC", 4) OR 176 PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) /= 177 CON (FALSE, 2, 3, 6.0) THEN 178 FAILED ("INCORRECT CONVERSION TO PARENT"); 179 END IF; 180 181 IF X.B /= TRUE OR X.L /= 3 OR 182 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR 183 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN 184 FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); 185 END IF; 186 187 IF X = CON (TRUE, 3, 1, "ABC", 5) OR 188 X = CON (FALSE, 2, 3, 6.0) THEN 189 FAILED ("INCORRECT ="); 190 END IF; 191 192 IF X /= CON (TRUE, 3, 1, "ABC", 4) OR 193 NOT (X /= CON (FALSE, 2, 3, 6.0)) THEN 194 FAILED ("INCORRECT /="); 195 END IF; 196 197 IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN 198 FAILED ("INCORRECT ""IN"""); 199 END IF; 200 201 IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN 202 FAILED ("INCORRECT ""NOT IN"""); 203 END IF; 204 205 B := FALSE; 206 A (X'ADDRESS); 207 IF NOT B THEN 208 FAILED ("INCORRECT 'ADDRESS"); 209 END IF; 210 211 IF NOT X'CONSTRAINED THEN 212 FAILED ("INCORRECT OBJECT'CONSTRAINED"); 213 END IF; 214 215 IF T'SIZE <= 0 THEN 216 FAILED ("INCORRECT TYPE'SIZE"); 217 END IF; 218 219 IF X'SIZE < T'SIZE OR 220 X.B'SIZE < BOOLEAN'SIZE OR 221 X.L'SIZE < LENGTH'SIZE THEN 222 FAILED ("INCORRECT OBJECT'SIZE"); 223 END IF; 224 225 RESULT; 226END C34009D; 227