1-- C37207A.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 27-- FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK 28-- THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING 29-- CONTEXTS AND HAS THE PROPER EFFECT: 30 31-- IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR 32-- 3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE, 33-- ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT 34-- VALUES WITHOUT RAISING CONSTRAINT_ERROR 35 36-- 4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES 37-- OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES 38-- DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES. 39 40-- 5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED 41-- DISCRIMINANT VALUES. 42 43-- 6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND 44-- HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO 45-- CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR, 46-- CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT 47-- VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS 48-- RAISED. 49 50-- HISTORY: 51 52-- ASL 07/24/81 53-- RJW 08/28/86 CORRECTED SYNTAX ERRORS. 54-- JLH 08/07/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION. 55-- EDS 07/16/98 AVOID OPTIMIZATION 56 57WITH REPORT; USE REPORT; 58PROCEDURE C37207A IS 59 60BEGIN 61 TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " & 62 "DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " & 63 "DEFAULT DISCRIMINANT VALUES"); 64 65 DECLARE 66 TYPE REC1 (DISC : INTEGER := 5) IS 67 RECORD 68 NULL; 69 END RECORD; 70 71 TYPE REC2 (DISC : INTEGER) IS 72 RECORD 73 NULL; 74 END RECORD; 75 76 OBJ1 : REC1(6); -- 1. 77 OBJ2 : REC2(6); -- 1. 78 BADOBJ1 : REC1(7); -- 1. 79 BADOBJ2 : REC2(7); -- 1. 80 81 TYPE REC3 IS 82 RECORD 83 COMP1 : REC1(6); -- 2. 84 COMP2 : REC2(6); -- 2. 85 END RECORD; 86 87 OBJ3 : REC3; 88 89 TYPE ARR1 IS ARRAY (1..10) OF REC1(6); -- 3. 90 TYPE ARR2 IS ARRAY (1..10) OF REC2(6); -- 3. 91 92 A1 : ARR1; 93 A2 : ARR2; 94 95 TYPE REC1_NAME IS ACCESS REC1(6); -- 4. 96 TYPE REC2_NAME IS ACCESS REC2(6); -- 4. 97 98 ACC1 : REC1_NAME; 99 ACC2 : REC2_NAME; 100 101 SUBTYPE REC16 IS REC1(6); 102 SUBTYPE REC26 IS REC2(6); 103 104 PROCEDURE PROC (P1 : IN OUT REC16; -- 6. 105 P2 : IN OUT REC26) IS -- 6. 106 BEGIN 107 IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN -- 6. 108 FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " & 109 "CONSTRAINED FORMAL PARAMETERS"); 110 END IF; 111 BEGIN 112 P1 := (DISC => 7); -- 6. 113 FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & 114 "ATTEMPT TO CHANGE DISCRIMINANT OF " & 115 "CONSTRAINED FORMAL PARAMETER " & 116 INTEGER'IMAGE(P1.DISC)); 117 EXCEPTION 118 WHEN CONSTRAINT_ERROR => NULL; 119 WHEN OTHERS => FAILED ("WRONG EXCEPTION (1)"); 120 END; 121 BEGIN 122 P2 := (DISC => 7); -- 6. 123 FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & 124 "ATTEMPT TO CHANGE DISCRIMINANT OF " & 125 "CONSTRAINED FORMAL PARAMETER " & 126 INTEGER'IMAGE(P2.DISC)); 127 EXCEPTION 128 WHEN CONSTRAINT_ERROR => NULL; 129 WHEN OTHERS => FAILED ("WRONG EXCEPTION (2)"); 130 END; 131 END PROC; 132 BEGIN 133--------------------------------------------------------------- 134 135 BEGIN 136 OBJ1 := (DISC => IDENT_INT(7)); -- 1. 137 FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & 138 "ATTEMPT TO CHANGE DISCRIMINANT OF " & 139 "CONSTRAINED OBJECT"); 140 IF OBJ1 = (DISC => 7) THEN 141 COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); 142 END IF; 143 EXCEPTION 144 WHEN CONSTRAINT_ERROR => NULL; 145 WHEN OTHERS => FAILED ("WRONG EXCEPTION (3)"); 146 END; 147 148--------------------------------------------------------------- 149 150 BEGIN 151 OBJ3 := ((DISC => IDENT_INT(7)), -- 2. 152 (DISC => IDENT_INT(7))); -- 2. 153 FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & 154 "ATTEMPT TO CHANGE DISCRIMINANT OF " & 155 "CONSTRAINED RECORD COMPONENT"); 156 IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN 157 COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); 158 END IF; 159 EXCEPTION 160 WHEN CONSTRAINT_ERROR => NULL; 161 WHEN OTHERS => FAILED ("WRONG EXCEPTION (4)"); 162 END; 163 164-------------------------------------------------------------- 165 166 BEGIN 167 A2(2) := (DISC => IDENT_INT(7)); -- 3. 168 FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & 169 "ATTEMPT TO CHANGE DISCRIMINANT OF " & 170 "CONSTRAINED ARRAY COMPONENT"); 171 IF A2(2) = (DISC => 7) THEN 172 COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); 173 END IF; 174 EXCEPTION 175 WHEN CONSTRAINT_ERROR => NULL; 176 WHEN OTHERS => FAILED ("WRONG EXCEPTION (5)"); 177 END; 178 179-------------------------------------------------------------- 180 181 BEGIN 182 ACC1 := NEW REC1(DISC => IDENT_INT(7)); -- 4. 183 FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & 184 "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " & 185 "TO ACCESS VARIABLE"); 186 IF ACC1 = NEW REC1(DISC => 7) THEN 187 COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); 188 END IF; 189 EXCEPTION 190 WHEN CONSTRAINT_ERROR => NULL; 191 WHEN OTHERS => FAILED ("WRONG EXCEPTION (6)"); 192 END; 193 194---------------------------------------------------------------- 195 196 ACC1 := NEW REC1(DISC => IDENT_INT(6)); -- OK. 197 198 BEGIN 199 ACC1.ALL := BADOBJ1; -- 5. 200 FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & 201 "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " & 202 "TO ACCESSED OBJECT"); 203 IF ACC1.ALL = BADOBJ1 THEN 204 COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION"); 205 END IF; 206 EXCEPTION 207 WHEN CONSTRAINT_ERROR => NULL; 208 WHEN OTHERS => FAILED ("WRONG EXCEPTION (7)"); 209 END; 210 211----------------------------------------------------------------- 212 213 PROC (OBJ1,OBJ2); -- OK. 214 215 BEGIN 216 PROC (BADOBJ1,BADOBJ2); -- 6. 217 FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & 218 "PASSING OF CONSTRAINED ACTUAL " & 219 "PARAMETERS TO DIFFERENTLY CONSTRAINED " & 220 "FORMAL PARAMETERS"); 221 EXCEPTION 222 WHEN CONSTRAINT_ERROR => NULL; 223 WHEN OTHERS => FAILED ("WRONG EXCEPTION (8)"); 224 END; 225 226--------------------------------------------------------------- 227 END; 228 229 RESULT; 230END C37207A; 231