1-- C85018B.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 WHEN AN ENTRY FAMILY MEMBER IS RENAMED THE FORMAL 27-- PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN 28-- FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY. 29 30-- HISTORY: 31-- RJW 06/03/86 CREATED ORIGINAL TEST. 32-- DHH 10/15/87 CORRECTED RANGE ERRORS. 33-- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY (INDEX CONSTRAINT). 34-- PWN 10/24/96 RESTORED CHECKS WITH ADA 95 RESULTS NOW EXPECTED. 35-- PWN 12/11/96 ADJUSTED VALUES FOR ADA 95 COMPATIBILITY. 36-- PWB.CTA 2/17/97 CHANGED CALL TO ENT2 TO NOT EXPECT EXCEPTION 37 38WITH REPORT; USE REPORT; 39 40PROCEDURE C85018B IS 41 42BEGIN 43 44 TEST( "C85018B", "CHECK THAT WHEN AN ENTRY FAMILY MEMBER IS " & 45 "RENAMED THE FORMAL PARAMETER CONSTRAINTS " & 46 "FOR THE NEW NAME ARE IGNORED IN FAVOR OF " & 47 "THE CONSTRAINTS ASSOCIATED WITH THE RENAMED " & 48 "ENTITY" ); 49 50 DECLARE 51 TYPE INT IS RANGE 1 .. 10; 52 SUBTYPE INT1 IS INT RANGE 1 .. 5; 53 SUBTYPE INT2 IS INT RANGE 6 .. 10; 54 55 OBJ1 : INT1 := 5; 56 OBJ2 : INT2 := 6; 57 58 SUBTYPE SHORTCHAR IS CHARACTER RANGE 'A' .. 'C'; 59 60 TASK T IS 61 ENTRY ENT1 (SHORTCHAR) 62 (A : INT1; OK : BOOLEAN); 63 END T; 64 65 PROCEDURE ENT2 (A : INT2; OK : BOOLEAN) 66 RENAMES T.ENT1 ('C'); 67 68 TASK BODY T IS 69 BEGIN 70 LOOP 71 SELECT 72 ACCEPT ENT1 ('C') 73 (A : INT1; OK : BOOLEAN) DO 74 IF NOT OK THEN 75 FAILED ( "WRONG CALL EXECUTED " & 76 "WITH INTEGER TYPE" ); 77 END IF; 78 END; 79 OR 80 TERMINATE; 81 END SELECT; 82 END LOOP; 83 END T; 84 BEGIN 85 BEGIN 86 ENT2 (OBJ1, TRUE); 87 EXCEPTION 88 WHEN CONSTRAINT_ERROR => 89 FAILED ( "CONSTRAINT_ERROR RAISED WITH " & 90 "INTEGER TYPE" ); 91 WHEN OTHERS => 92 FAILED ( "OTHER EXCEPTION RAISED WITH " & 93 "INTEGER TYPE - 1" ); 94 END; 95 96 BEGIN 97 ENT2 (OBJ2, TRUE); 98 EXCEPTION 99 WHEN CONSTRAINT_ERROR => 100 NULL; 101 WHEN OTHERS => 102 FAILED ( "OTHER EXCEPTION RAISED WITH " & 103 "INTEGER TYPE - 2" ); 104 END; 105 END; 106 107 DECLARE 108 TYPE REAL IS DIGITS 3; 109 SUBTYPE REAL1 IS REAL RANGE -2.0 .. 0.0; 110 SUBTYPE REAL2 IS REAL RANGE 0.0 .. 2.0; 111 112 OBJ1 : REAL1 := -0.25; 113 OBJ2 : REAL2 := 0.25; 114 115 SUBTYPE SHORTINT IS INTEGER RANGE 9 .. 11; 116 117 TASK T IS 118 ENTRY ENT1 (SHORTINT) 119 (A : REAL1; OK : BOOLEAN); 120 END T; 121 122 PROCEDURE ENT2 (A : REAL2; OK : BOOLEAN) 123 RENAMES T.ENT1 (10); 124 125 TASK BODY T IS 126 BEGIN 127 LOOP 128 SELECT 129 ACCEPT ENT1 (10) 130 (A : REAL1; OK : BOOLEAN) DO 131 IF NOT OK THEN 132 FAILED ( "WRONG CALL EXECUTED " & 133 "WITH FLOATING POINT " & 134 "TYPE" ); 135 END IF; 136 END; 137 OR 138 TERMINATE; 139 END SELECT; 140 END LOOP; 141 END T; 142 BEGIN 143 BEGIN 144 ENT2 (OBJ1, TRUE); 145 EXCEPTION 146 WHEN CONSTRAINT_ERROR => 147 FAILED ( "CONSTRAINT_ERROR RAISED WITH " & 148 "FLOATING POINT " & 149 "TYPE" ); 150 WHEN OTHERS => 151 FAILED ( "OTHER EXCEPTION RAISED WITH " & 152 "FLOATING POINT " & 153 "TYPE - 1" ); 154 END; 155 156 BEGIN 157 ENT2 (OBJ2, FALSE); 158 EXCEPTION 159 WHEN CONSTRAINT_ERROR => 160 NULL; 161 WHEN OTHERS => 162 FAILED ( "OTHER EXCEPTION RAISED WITH " & 163 "FLOATING POINT " & 164 "TYPE - 2" ); 165 END; 166 END; 167 168 DECLARE 169 TYPE COLOR IS (RED, YELLOW, BLUE, GREEN); 170 171 TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0; 172 SUBTYPE FIXED1 IS FIXED RANGE 0.0 .. 0.5; 173 SUBTYPE FIXED2 IS FIXED RANGE -0.5 .. 0.0; 174 175 OBJ1 : FIXED1 := 0.125; 176 OBJ2 : FIXED2 := -0.125; 177 178 TASK T IS 179 ENTRY ENT1 (COLOR) 180 (A : FIXED1; OK : BOOLEAN); 181 END T; 182 183 PROCEDURE ENT2 (A : FIXED2; OK : BOOLEAN) 184 RENAMES T.ENT1 (BLUE); 185 186 TASK BODY T IS 187 BEGIN 188 LOOP 189 SELECT 190 ACCEPT ENT1 (BLUE) 191 (A : FIXED1; OK : BOOLEAN) DO 192 IF NOT OK THEN 193 FAILED ( "WRONG CALL EXECUTED " & 194 "WITH FIXED POINT " & 195 "TYPE" ); 196 END IF; 197 END; 198 OR 199 TERMINATE; 200 END SELECT; 201 END LOOP; 202 END T; 203 BEGIN 204 BEGIN 205 ENT2 (OBJ1, TRUE); 206 EXCEPTION 207 WHEN CONSTRAINT_ERROR => 208 FAILED ( "CONSTRAINT_ERROR RAISED WITH " & 209 "FIXED POINT " & 210 "TYPE" ); 211 WHEN OTHERS => 212 FAILED ( "OTHER EXCEPTION RAISED WITH " & 213 "FIXED POINT " & 214 "TYPE - 1" ); 215 END; 216 217 BEGIN 218 ENT2 (OBJ2, FALSE); 219 EXCEPTION 220 WHEN CONSTRAINT_ERROR => 221 NULL; 222 WHEN OTHERS => 223 FAILED ( "OTHER EXCEPTION RAISED WITH " & 224 "FIXED POINT " & 225 "TYPE - 2" ); 226 END; 227 END; 228 229 DECLARE 230 TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER; 231 SUBTYPE STA1 IS TA(1 .. 5); 232 SUBTYPE STA2 IS TA(6 .. 10); 233 234 OBJ1 : STA1 := (1, 2, 3, 4, 5); 235 OBJ2 : STA2 := (6, 7, 8, 9, 10); 236 237 TASK T IS 238 ENTRY ENT1 (BOOLEAN) 239 (A : STA1; OK : BOOLEAN); 240 END T; 241 242 PROCEDURE ENT2 (A : STA2; OK : BOOLEAN) 243 RENAMES T.ENT1 (FALSE); 244 245 TASK BODY T IS 246 BEGIN 247 LOOP 248 SELECT 249 ACCEPT ENT1 (FALSE) 250 (A : STA1; OK : BOOLEAN) DO 251 IF NOT OK THEN 252 FAILED ( "WRONG CALL EXECUTED " & 253 "WITH CONSTRAINED " & 254 "ARRAY" ); 255 END IF; 256 END; 257 OR 258 TERMINATE; 259 END SELECT; 260 END LOOP; 261 END T; 262 BEGIN 263 BEGIN 264 ENT2 (OBJ1, TRUE); 265 EXCEPTION 266 WHEN CONSTRAINT_ERROR => 267 FAILED ( "CONSTRAINT_ERROR RAISED WITH " & 268 "CONSTRAINED ARRAY" ); 269 WHEN OTHERS => 270 FAILED ( "OTHER EXCEPTION RAISED WITH " & 271 "CONSTRAINED ARRAY - 1" ); 272 END; 273 274 BEGIN 275 ENT2 (OBJ2, TRUE); 276 EXCEPTION 277 WHEN CONSTRAINT_ERROR => 278 FAILED ( "CONSTRAINT_ERROR RAISED WITH " & 279 "CONSTRAINED ARRAY" ); 280 WHEN OTHERS => 281 FAILED ( "OTHER EXCEPTION RAISED WITH " & 282 "CONSTRAINED ARRAY - 2" ); 283 END; 284 END; 285 286 RESULT; 287 288END C85018B; 289