1-- C34009F.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 NON-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 08/31/87 CREATED ORIGINAL TEST. 37 38WITH REPORT; USE REPORT; 39 40PROCEDURE C34009F 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 := 1) IS PRIVATE; 49 50 FUNCTION CREATE ( B : BOOLEAN; 51 L : LENGTH; 52 I : INTEGER; 53 S : STRING; 54 J : INTEGER; 55 F : FLOAT; 56 X : PARENT -- TO RESOLVE OVERLOADING. 57 ) RETURN PARENT; 58 59 FUNCTION CON ( B : BOOLEAN; 60 L : LENGTH; 61 I : INTEGER; 62 S : STRING; 63 J : INTEGER 64 ) RETURN PARENT; 65 66 FUNCTION CON ( B : BOOLEAN; 67 L : LENGTH; 68 I : INTEGER; 69 F : FLOAT 70 ) RETURN PARENT; 71 72 PRIVATE 73 74 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS 75 RECORD 76 I : INTEGER; 77 CASE B IS 78 WHEN TRUE => 79 S : STRING (1 .. L); 80 J : INTEGER; 81 WHEN FALSE => 82 F : FLOAT := 5.0; 83 END CASE; 84 END RECORD; 85 86 END PKG; 87 88 USE PKG; 89 90 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); 91 92 SUBTYPE SUBPARENT IS PARENT (TRUE, 3); 93 94 TYPE S IS NEW SUBPARENT; 95 96 X : T; 97 Y : S; 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 ("C34009F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 147 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 148 "WHEN THE DERIVED TYPE DEFINITION IS " & 149 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 150 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 151 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 152 "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); 153 154 X := CON (TRUE, 3, 2, "AAA", 2); 155 Y := CON (TRUE, 3, 2, "AAA", 2); 156 157 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 158 159 IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /= 160 CON (FALSE, 2, 3, 6.0) OR 161 CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /= 162 CON (FALSE, 2, 3, 6.0) THEN 163 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); 164 END IF; 165 166 IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR 167 CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN 168 FAILED ("INCORRECT ""IN"""); 169 END IF; 170 171 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 172 173 IF X.B /= TRUE OR X.L /= 3 OR 174 Y.B /= TRUE OR Y.L /= 3 THEN 175 FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); 176 END IF; 177 178 IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN 179 FAILED ("INCORRECT 'CONSTRAINED"); 180 END IF; 181 182 BEGIN 183 X := CON (TRUE, 3, 1, "ABC", 4); 184 Y := CON (TRUE, 3, 1, "ABC", 4); 185 IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. 186 FAILED ("INCORRECT CONVERSION TO PARENT"); 187 END IF; 188 EXCEPTION 189 WHEN OTHERS => 190 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); 191 END; 192 193 BEGIN 194 X := CON (FALSE, 3, 2, 6.0); 195 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 196 "X := CON (FALSE, 3, 2, 6.0)"); 197 IF X = CON (FALSE, 3, 2, 6.0) THEN -- USE X. 198 COMMENT ("X ALTERED -- X := CON (FALSE, 3, 2, 6.0)"); 199 END IF; 200 EXCEPTION 201 WHEN CONSTRAINT_ERROR => 202 NULL; 203 WHEN OTHERS => 204 FAILED ("WRONG EXCEPTION RAISED -- " & 205 "X := CON (FALSE, 3, 2, 6.0)"); 206 END; 207 208 BEGIN 209 X := CON (TRUE, 4, 2, "ZZZZ", 6); 210 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 211 "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); 212 IF X = CON (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. 213 COMMENT ("X ALTERED -- " & 214 "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); 215 END IF; 216 EXCEPTION 217 WHEN CONSTRAINT_ERROR => 218 NULL; 219 WHEN OTHERS => 220 FAILED ("WRONG EXCEPTION RAISED -- " & 221 "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); 222 END; 223 224 BEGIN 225 Y := CON (FALSE, 3, 2, 6.0); 226 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 227 "Y := CON (FALSE, 3, 2, 6.0)"); 228 IF Y = CON (FALSE, 3, 2, 6.0) THEN -- USE Y. 229 COMMENT ("Y ALTERED -- Y := CON (FALSE, 3, 2, 6.0)"); 230 END IF; 231 EXCEPTION 232 WHEN CONSTRAINT_ERROR => 233 NULL; 234 WHEN OTHERS => 235 FAILED ("WRONG EXCEPTION RAISED -- " & 236 "Y := CON (FALSE, 3, 2, 6.0)"); 237 END; 238 239 BEGIN 240 Y := CON (TRUE, 4, 2, "ZZZZ", 6); 241 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 242 "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); 243 IF Y = CON (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. 244 COMMENT ("Y ALTERED -- " & 245 "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); 246 END IF; 247 EXCEPTION 248 WHEN CONSTRAINT_ERROR => 249 NULL; 250 WHEN OTHERS => 251 FAILED ("WRONG EXCEPTION RAISED -- " & 252 "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); 253 END; 254 255 RESULT; 256END C34009F; 257