1-- C34009L.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 LIMITED PRIVATE TYPES WITH DISCRIMINANTS: 27 28-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT 29-- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION 30-- IS CONSTRAINED. 31 32-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS 33-- ALSO IMPOSED ON THE DERIVED SUBTYPE. 34 35-- HISTORY: 36-- JRK 09/01/87 CREATED ORIGINAL TEST. 37 38WITH REPORT; USE REPORT; 39 40PROCEDURE C34009L IS 41 42 PACKAGE PKG IS 43 44 MAX_LEN : CONSTANT := 10; 45 46 SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; 47 48 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS 49 LIMITED PRIVATE; 50 51 FUNCTION CREATE ( B : BOOLEAN; 52 L : LENGTH; 53 I : INTEGER; 54 S : STRING; 55 J : INTEGER; 56 F : FLOAT; 57 X : PARENT -- TO RESOLVE OVERLOADING. 58 ) RETURN PARENT; 59 60 FUNCTION CON ( B : BOOLEAN; 61 L : LENGTH; 62 I : INTEGER; 63 S : STRING; 64 J : INTEGER 65 ) RETURN PARENT; 66 67 FUNCTION CON ( B : BOOLEAN; 68 L : LENGTH; 69 I : INTEGER; 70 F : FLOAT 71 ) RETURN PARENT; 72 73 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; 74 75 PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT); 76 77 PRIVATE 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 J : INTEGER := 2; 86 WHEN FALSE => 87 F : FLOAT := 5.0; 88 END CASE; 89 END RECORD; 90 91 END PKG; 92 93 USE PKG; 94 95 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); 96 97 SUBTYPE SUBPARENT IS PARENT (TRUE, 3); 98 99 TYPE S IS NEW SUBPARENT; 100 101 X : T; 102 Y : S; 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 ("C34009L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 162 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 163 "WHEN THE DERIVED TYPE DEFINITION IS " & 164 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 165 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 166 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 167 "LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); 168 169 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 170 171 IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X), 172 CON (FALSE, 2, 3, 6.0)) OR 173 NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y), 174 CON (FALSE, 2, 3, 6.0)) THEN 175 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); 176 END IF; 177 178 IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR 179 CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN 180 FAILED ("INCORRECT ""IN"""); 181 END IF; 182 183 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 184 185 IF X.B /= TRUE OR X.L /= 3 OR 186 Y.B /= TRUE OR Y.L /= 3 THEN 187 FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); 188 END IF; 189 190 IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN 191 FAILED ("INCORRECT 'CONSTRAINED"); 192 END IF; 193 194 BEGIN 195 ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4)); 196 ASSIGN (Y, CON (TRUE, 3, 1, "ABC", 4)); 197 IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. 198 FAILED ("INCORRECT CONVERSION TO PARENT"); 199 END IF; 200 EXCEPTION 201 WHEN OTHERS => 202 FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); 203 END; 204 205 BEGIN 206 ASSIGN (X, CON (FALSE, 3, 2, 6.0)); 207 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 208 "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); 209 IF EQUAL (X, CON (FALSE, 3, 2, 6.0)) THEN -- USE X. 210 COMMENT ("X ALTERED -- " & 211 "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); 212 END IF; 213 EXCEPTION 214 WHEN CONSTRAINT_ERROR => 215 NULL; 216 WHEN OTHERS => 217 FAILED ("WRONG EXCEPTION RAISED -- " & 218 "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); 219 END; 220 221 BEGIN 222 ASSIGN (X, CON (TRUE, 4, 2, "ZZZZ", 6)); 223 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 224 "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); 225 IF EQUAL (X, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN -- USE X. 226 COMMENT ("X ALTERED -- " & 227 "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); 228 END IF; 229 EXCEPTION 230 WHEN CONSTRAINT_ERROR => 231 NULL; 232 WHEN OTHERS => 233 FAILED ("WRONG EXCEPTION RAISED -- " & 234 "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); 235 END; 236 237 BEGIN 238 ASSIGN (Y, CON (FALSE, 3, 2, 6.0)); 239 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 240 "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); 241 IF EQUAL (Y, CON (FALSE, 3, 2, 6.0)) THEN -- USE Y. 242 COMMENT ("Y ALTERED -- " & 243 "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); 244 END IF; 245 EXCEPTION 246 WHEN CONSTRAINT_ERROR => 247 NULL; 248 WHEN OTHERS => 249 FAILED ("WRONG EXCEPTION RAISED -- " & 250 "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); 251 END; 252 253 BEGIN 254 ASSIGN (Y, CON (TRUE, 4, 2, "ZZZZ", 6)); 255 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 256 "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); 257 IF EQUAL (Y, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN -- USE Y. 258 COMMENT ("Y ALTERED -- " & 259 "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); 260 END IF; 261 EXCEPTION 262 WHEN CONSTRAINT_ERROR => 263 NULL; 264 WHEN OTHERS => 265 FAILED ("WRONG EXCEPTION RAISED -- " & 266 "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); 267 END; 268 269 RESULT; 270END C34009L; 271