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