1-- C47008A.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-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A 27-- CONSTRAINED RECORD, PRIVATE, OR LIMITED PRIVATE TYPE, CHECK THAT 28-- CONSTRAINT_ERROR IS RAISED WHEN THE DISCRIMINANTS OF THE OPERAND 29-- DO NOT EQUAL THOSE OF THE TYPE MARK. 30 31-- HISTORY: 32-- RJW 07/23/86 33-- DWC 07/24/87 CHANGED CODE TO TEST FOR FIRST DISCRIMINANT 34-- AND LAST DISCRIMINANT MISMATCH. 35 36WITH REPORT; USE REPORT; 37PROCEDURE C47008A IS 38 39 TYPE GENDER IS (MALE, FEMALE, NEUTER); 40 41 FUNCTION IDENT (G : GENDER) RETURN GENDER IS 42 BEGIN 43 RETURN GENDER'VAL (IDENT_INT (GENDER'POS (G))); 44 END IDENT; 45 46BEGIN 47 48 TEST( "C47008A", "WHEN THE TYPE MARK IN A QUALIFIED " & 49 "EXPRESSION DENOTES A CONSTRAINED RECORD, " & 50 "PRIVATE, OR LIMITED PRIVATE TYPE, CHECK " & 51 "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " & 52 "DISCRIMANTS OF THE OPERAND DO NOT EQUAL " & 53 "THOSE OF THE TYPE MARK" ); 54 55 DECLARE 56 57 TYPE PERSON (SEX : GENDER) IS 58 RECORD 59 NULL; 60 END RECORD; 61 62 SUBTYPE WOMAN IS PERSON (IDENT (FEMALE)); 63 TOM : PERSON (MALE) := (SEX => IDENT (MALE)); 64 65 BEGIN 66 IF WOMAN'(TOM) = PERSON'(SEX => MALE) THEN 67 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & 68 "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 1"); 69 ELSE 70 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & 71 "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 2"); 72 END IF; 73 EXCEPTION 74 WHEN CONSTRAINT_ERROR => 75 NULL; 76 WHEN OTHERS => 77 FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & 78 "DISC NOT EQUAL TO THOSE OF SUBTYPE WOMAN" ); 79 END; 80 81 DECLARE 82 TYPE PAIR (SEX1, SEX2 : GENDER) IS 83 RECORD 84 NULL; 85 END RECORD; 86 87 SUBTYPE COUPLE IS PAIR (IDENT (FEMALE), IDENT (MALE)); 88 JONESES : PAIR (IDENT (MALE), IDENT (FEMALE)); 89 90 BEGIN 91 IF COUPLE'(JONESES) = PAIR'(SEX1 => MALE, SEX2 => FEMALE) 92 THEN 93 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & 94 "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 1"); 95 ELSE 96 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & 97 "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 2"); 98 END IF; 99 EXCEPTION 100 WHEN CONSTRAINT_ERROR => 101 NULL; 102 WHEN OTHERS => 103 FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & 104 "DISC NOT EQUAL TO THOSE OF SUBTYPE COUPLE" ); 105 END; 106 107 DECLARE 108 109 PACKAGE PKG IS 110 TYPE PERSON (SEX : GENDER) IS PRIVATE; 111 SUBTYPE MAN IS PERSON (IDENT (MALE)); 112 113 TESTWRITER : CONSTANT PERSON; 114 115 PRIVATE 116 TYPE PERSON (SEX : GENDER) IS 117 RECORD 118 NULL; 119 END RECORD; 120 121 TESTWRITER : CONSTANT PERSON := (SEX => FEMALE); 122 123 END PKG; 124 125 USE PKG; 126 127 ROSA : PERSON (IDENT (FEMALE)); 128 129 BEGIN 130 IF MAN'(ROSA) = TESTWRITER THEN 131 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & 132 "NOT EQUAL TO THOSE OF SUBTYPE MAN - 1" ); 133 ELSE 134 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & 135 "NOT EQUAL TO THOSE OF SUBTYPE MAN - 2" ); 136 END IF; 137 EXCEPTION 138 WHEN CONSTRAINT_ERROR => 139 NULL; 140 WHEN OTHERS => 141 FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & 142 "DISC NOT EQUAL TO THOSE OF SUBTYPE MAN" ); 143 END; 144 145 DECLARE 146 PACKAGE PKG IS 147 TYPE PAIR (SEX1, SEX2 : GENDER) IS PRIVATE; 148 SUBTYPE FRIENDS IS PAIR (IDENT (FEMALE), IDENT (MALE)); 149 150 ALICE_AND_JERRY : CONSTANT FRIENDS; 151 152 PRIVATE 153 TYPE PAIR (SEX1, SEX2 : GENDER) IS 154 RECORD 155 NULL; 156 END RECORD; 157 158 ALICE_AND_JERRY : CONSTANT FRIENDS := 159 (IDENT (FEMALE), IDENT (MALE)); 160 161 END PKG; 162 163 USE PKG; 164 165 DICK_AND_JOE : PAIR (IDENT (MALE), IDENT (MALE)); 166 167 BEGIN 168 IF FRIENDS'(DICK_AND_JOE) = ALICE_AND_JERRY THEN 169 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & 170 "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 1"); 171 ELSE 172 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & 173 "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 2"); 174 END IF; 175 EXCEPTION 176 WHEN CONSTRAINT_ERROR => 177 NULL; 178 WHEN OTHERS => 179 FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & 180 "DISC NOT EQUAL TO THOSE OF SUBTYPE FRIENDS" ); 181 END; 182 183 DECLARE 184 185 PACKAGE PKG1 IS 186 TYPE PERSON (SEX : GENDER) IS LIMITED PRIVATE; 187 SUBTYPE ANDROID IS PERSON (IDENT (NEUTER)); 188 189 FUNCTION F RETURN PERSON; 190 FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN; 191 PRIVATE 192 TYPE PERSON (SEX : GENDER) IS 193 RECORD 194 NULL; 195 END RECORD; 196 197 END PKG1; 198 199 PACKAGE BODY PKG1 IS 200 201 FUNCTION F RETURN PERSON IS 202 BEGIN 203 RETURN PERSON'(SEX => (IDENT (MALE))); 204 END F; 205 206 FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN IS 207 BEGIN 208 RETURN A.SEX = B.SEX; 209 END; 210 211 END PKG1; 212 213 PACKAGE PKG2 IS END PKG2; 214 215 PACKAGE BODY PKG2 IS 216 USE PKG1; 217 218 BEGIN 219 IF ANDROID'(F) = F THEN 220 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & 221 "DISC NOT EQUAL TO THOSE OF SUBTYPE " & 222 "ANDROID - 1"); 223 ELSE 224 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & 225 "DISC NOT EQUAL TO THOSE OF SUBTYPE " & 226 "ANDROID - 2"); 227 END IF; 228 EXCEPTION 229 WHEN CONSTRAINT_ERROR => 230 NULL; 231 WHEN OTHERS => 232 FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " & 233 "WITH DISC NOT EQUAL TO THOSE OF " & 234 "SUBTYPE ANDROID" ); 235 END PKG2; 236 237 BEGIN 238 NULL; 239 END; 240 241 DECLARE 242 PACKAGE PKG1 IS 243 TYPE PAIR (SEX1, SEX2 : GENDER) IS LIMITED PRIVATE; 244 SUBTYPE LOVERS IS PAIR (IDENT (FEMALE), IDENT (MALE)); 245 246 FUNCTION F RETURN PAIR; 247 FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN; 248 PRIVATE 249 TYPE PAIR (SEX1, SEX2 : GENDER) IS 250 RECORD 251 NULL; 252 END RECORD; 253 END PKG1; 254 255 PACKAGE BODY PKG1 IS 256 257 FUNCTION F RETURN PAIR IS 258 BEGIN 259 RETURN PAIR'(SEX1 => (IDENT (FEMALE)), 260 SEX2 => (IDENT (FEMALE))); 261 END F; 262 263 FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN IS 264 BEGIN 265 RETURN A.SEX1 = B.SEX2; 266 END; 267 268 END PKG1; 269 270 PACKAGE PKG2 IS END PKG2; 271 272 PACKAGE BODY PKG2 IS 273 USE PKG1; 274 275 BEGIN 276 IF LOVERS'(F) = F THEN 277 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & 278 "DISC NOT EQUAL TO THOSE OF SUBTYPE " & 279 "LOVERS - 1"); 280 ELSE 281 FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & 282 "DISC NOT EQUAL TO THOSE OF SUBTYPE " & 283 "LOVERS - 2"); 284 END IF; 285 EXCEPTION 286 WHEN CONSTRAINT_ERROR => 287 NULL; 288 WHEN OTHERS => 289 FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " & 290 "WITH DISC NOT EQUAL TO THOSE OF " & 291 "SUBTYPE LOVERS" ); 292 END PKG2; 293 294 BEGIN 295 NULL; 296 END; 297 298 RESULT; 299END C47008A; 300