1-- C34007U.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-- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A PRIVATE TYPE 26-- WITH DISCRIMINANTS: 27 28-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE 29-- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS 30-- CONSTRAINED. 31 32-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO 33-- IMPOSED ON THE DERIVED SUBTYPE. 34 35-- JRK 9/30/86 36 37WITH REPORT; USE REPORT; 38 39PROCEDURE C34007U IS 40 41 SUBTYPE COMPONENT IS INTEGER; 42 43 PACKAGE PKG_D IS 44 45 SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; 46 47 TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS 48 PRIVATE; 49 50 FUNCTION CREATE ( B : BOOLEAN; 51 L : LENGTH; 52 I : INTEGER; 53 S : STRING; 54 C : COMPONENT; 55 F : FLOAT 56 ) RETURN DESIGNATED; 57 58 PRIVATE 59 60 TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS 61 RECORD 62 I : INTEGER := 2; 63 CASE B IS 64 WHEN TRUE => 65 S : STRING (1 .. L) := (1 .. L => 'A'); 66 C : COMPONENT := 2; 67 WHEN FALSE => 68 F : FLOAT := 5.0; 69 END CASE; 70 END RECORD; 71 72 END PKG_D; 73 74 USE PKG_D; 75 76 PACKAGE PKG_P IS 77 78 TYPE PARENT IS ACCESS DESIGNATED; 79 80 FUNCTION CREATE ( B : BOOLEAN; 81 L : LENGTH; 82 I : INTEGER; 83 S : STRING; 84 C : COMPONENT; 85 F : FLOAT; 86 X : PARENT -- TO RESOLVE OVERLOADING. 87 ) RETURN PARENT; 88 89 END PKG_P; 90 91 USE PKG_P; 92 93 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); 94 95 SUBTYPE SUBPARENT IS PARENT (TRUE, 3); 96 97 TYPE S IS NEW SUBPARENT; 98 99 X : T := NEW DESIGNATED (TRUE, 3); 100 Y : S := NEW DESIGNATED (TRUE, 3); 101 102 PACKAGE BODY PKG_D IS 103 104 FUNCTION CREATE 105 ( B : BOOLEAN; 106 L : LENGTH; 107 I : INTEGER; 108 S : STRING; 109 C : COMPONENT; 110 F : FLOAT 111 ) RETURN DESIGNATED 112 IS 113 BEGIN 114 CASE B IS 115 WHEN TRUE => 116 RETURN (TRUE, L, I, S, C); 117 WHEN FALSE => 118 RETURN (FALSE, L, I, F); 119 END CASE; 120 END CREATE; 121 122 END PKG_D; 123 124 PACKAGE BODY PKG_P IS 125 126 FUNCTION CREATE 127 ( B : BOOLEAN; 128 L : LENGTH; 129 I : INTEGER; 130 S : STRING; 131 C : COMPONENT; 132 F : FLOAT; 133 X : PARENT 134 ) RETURN PARENT 135 IS 136 BEGIN 137 RETURN NEW DESIGNATED'(CREATE (B, L, I, S, C, F)); 138 END CREATE; 139 140 END PKG_P; 141 142BEGIN 143 TEST ("C34007U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 144 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 145 "WHEN THE DERIVED TYPE DEFINITION IS " & 146 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 147 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 148 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 149 "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & 150 "PRIVATE TYPE WITH DISCRIMINANTS"); 151 152 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 153 154 IF CREATE (FALSE, 2, 3, "WW", 5, 6.0, X) . ALL /= 155 CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) OR 156 CREATE (FALSE, 2, 3, "WW", 5, 6.0, Y) . ALL /= 157 CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN 158 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); 159 END IF; 160 161 IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR 162 CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN 163 FAILED ("INCORRECT ""IN"""); 164 END IF; 165 166 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 167 168 IF X.B /= TRUE OR X.L /= 3 OR 169 Y.B /= TRUE OR Y.L /= 3 THEN 170 FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); 171 END IF; 172 173 BEGIN 174 X := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)); 175 Y := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)); 176 IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. 177 X.ALL /= Y.ALL THEN 178 FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); 179 END IF; 180 EXCEPTION 181 WHEN OTHERS => 182 FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); 183 END; 184 185 BEGIN 186 X := NEW DESIGNATED'(CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0)); 187 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 188 "X := NEW DESIGNATED'" & 189 "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); 190 IF X = NULL OR ELSE 191 X.ALL = CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0) THEN -- USE X. 192 COMMENT ("X ALTERED -- " & 193 "X := NEW DESIGNATED'" & 194 "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); 195 END IF; 196 EXCEPTION 197 WHEN CONSTRAINT_ERROR => 198 NULL; 199 WHEN OTHERS => 200 FAILED ("WRONG EXCEPTION RAISED -- " & 201 "X := NEW DESIGNATED'" & 202 "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); 203 END; 204 205 BEGIN 206 X := NEW DESIGNATED'(CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0)); 207 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 208 "X := NEW DESIGNATED'" & 209 "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); 210 IF X = NULL OR ELSE 211 X.ALL = CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0) THEN -- USE X. 212 COMMENT ("X ALTERED -- " & 213 "X := NEW DESIGNATED'" & 214 "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); 215 END IF; 216 EXCEPTION 217 WHEN CONSTRAINT_ERROR => 218 NULL; 219 WHEN OTHERS => 220 FAILED ("WRONG EXCEPTION RAISED -- " & 221 "X := NEW DESIGNATED'" & 222 "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); 223 END; 224 225 BEGIN 226 Y := NEW DESIGNATED'(CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0)); 227 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 228 "Y := NEW DESIGNATED'" & 229 "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); 230 IF Y = NULL OR ELSE 231 Y.ALL = CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0) THEN -- USE Y. 232 COMMENT ("Y ALTERED -- " & 233 "Y := NEW DESIGNATED'" & 234 "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); 235 END IF; 236 EXCEPTION 237 WHEN CONSTRAINT_ERROR => 238 NULL; 239 WHEN OTHERS => 240 FAILED ("WRONG EXCEPTION RAISED -- " & 241 "Y := NEW DESIGNATED'" & 242 "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); 243 END; 244 245 BEGIN 246 Y := NEW DESIGNATED'(CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0)); 247 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 248 "Y := NEW DESIGNATED'" & 249 "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); 250 IF Y = NULL OR ELSE 251 Y.ALL = CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0) THEN -- USE Y. 252 COMMENT ("Y ALTERED -- " & 253 "Y := NEW DESIGNATED'" & 254 "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); 255 END IF; 256 EXCEPTION 257 WHEN CONSTRAINT_ERROR => 258 NULL; 259 WHEN OTHERS => 260 FAILED ("WRONG EXCEPTION RAISED -- " & 261 "Y := NEW DESIGNATED'" & 262 "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); 263 END; 264 265 RESULT; 266END C34007U; 267