1-- C37108B.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-- CHECK THAT CONSTRAINT_ERROR IS RAISED IN AN OBJECT DECLARATION IF 26-- A DEFAULT INITIAL VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE 27-- CONSTRAINTS OF A RECORD OR AN ARRAY TYPE WHOSE CONSTRAINT 28-- DEPENDS ON A DISCRIMINANT, AND NO EXPLICIT INITIALIZATION IS 29-- PROVIDED FOR THE OBJECT. 30 31-- R.WILLIAMS 8/25/86 32-- EDS 7/16/98 AVOID OPTIMIZATION 33 34WITH REPORT; USE REPORT; 35PROCEDURE C37108B IS 36 37 TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; 38 39 TYPE R (P : POSITIVE) IS 40 RECORD 41 NULL; 42 END RECORD; 43 44BEGIN 45 TEST ( "C37108B", "CHECK THAT CONSTRAINT_ERROR IS RAISED IN " & 46 "AN OBJECT DECLARATION IF A DEFAULT INITIAL " & 47 "VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE " & 48 "CONSTRAINTS OF A RECORD OR AN ARRAY TYPE " & 49 "WHOSE CONSTRAINT DEPENDS ON A DISCRIMINANT, " & 50 "AND NO EXPLICIT INITIALIZATION IS PROVIDED " & 51 "FOR THE OBJECT" ); 52 53 54 BEGIN 55 DECLARE 56 TYPE REC1 (D : NATURAL := IDENT_INT (0)) IS 57 RECORD 58 A : ARR (D .. 5); 59 END RECORD; 60 61 BEGIN 62 DECLARE 63 R1 : REC1; 64 65 BEGIN 66 R1.A (1) := IDENT_INT (2); 67 FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " & 68 "R1" & INTEGER'IMAGE(R1.A(5))); --USE R2 69 EXCEPTION 70 WHEN OTHERS => 71 FAILED ( "EXCEPTION FOR R1 RAISED INSIDE " & 72 "BLOCK" ); 73 END; 74 75 EXCEPTION 76 WHEN CONSTRAINT_ERROR => 77 NULL; 78 WHEN OTHERS => 79 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & 80 "OF R1" ); 81 END; 82 83 EXCEPTION 84 WHEN CONSTRAINT_ERROR => 85 FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & 86 "DECLARATION OF REC1" ); 87 WHEN OTHERS => 88 FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & 89 "DECLARATION OF REC1" ); 90 END; 91 92 BEGIN 93 DECLARE 94 TYPE REC2 (D : INTEGER := IDENT_INT (-1)) IS 95 RECORD 96 A : R (P => D); 97 END RECORD; 98 99 BEGIN 100 DECLARE 101 R2 : REC2; 102 103 BEGIN 104 R2.A := R'(P => IDENT_INT (1)); 105 FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " & 106 "R2" & INTEGER'IMAGE(R2.A.P)); --USE R2 107 EXCEPTION 108 WHEN OTHERS => 109 FAILED ( "EXCEPTION FOR R2 RAISED INSIDE " & 110 "BLOCK" ); 111 END; 112 113 EXCEPTION 114 WHEN CONSTRAINT_ERROR => 115 NULL; 116 WHEN OTHERS => 117 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & 118 "OF R2" ); 119 END; 120 121 EXCEPTION 122 WHEN CONSTRAINT_ERROR => 123 FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & 124 "DECLARATION OF REC2" ); 125 WHEN OTHERS => 126 FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & 127 "DECLARATION OF REC2" ); 128 END; 129 130 BEGIN 131 DECLARE 132 PACKAGE PRIV IS 133 TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS 134 PRIVATE; 135 PROCEDURE PROC (R :REC3); 136 137 PRIVATE 138 TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS 139 RECORD 140 A : R (P => D); 141 END RECORD; 142 END PRIV; 143 144 PACKAGE BODY PRIV IS 145 PROCEDURE PROC (R : REC3) IS 146 I : INTEGER; 147 BEGIN 148 I := IDENT_INT (R.A.P); 149 IF EQUAL(2, IDENT_INT(1)) THEN 150 FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I)); --USE I 151 END IF; 152 END PROC; 153 END PRIV; 154 155 USE PRIV; 156 157 BEGIN 158 DECLARE 159 R3 : REC3; 160 161 BEGIN 162 PROC (R3); 163 FAILED ( "NO EXCEPTION RAISED AT " & 164 "DECLARATION OF R3" ); 165 EXCEPTION 166 WHEN OTHERS => 167 FAILED ( "EXCEPTION FOR R3 RAISED INSIDE " & 168 "BLOCK" ); 169 END; 170 171 EXCEPTION 172 WHEN CONSTRAINT_ERROR => 173 NULL; 174 WHEN OTHERS => 175 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & 176 "OF R3" ); 177 END; 178 179 EXCEPTION 180 WHEN CONSTRAINT_ERROR => 181 FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & 182 "DECLARATION OF REC3" ); 183 WHEN OTHERS => 184 FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & 185 "DECLARATION OF REC3" ); 186 END; 187 188 BEGIN 189 DECLARE 190 PACKAGE LPRIV IS 191 TYPE REC4 (D : NATURAL := IDENT_INT (0)) 192 IS LIMITED PRIVATE; 193 PROCEDURE PROC (R :REC4); 194 195 PRIVATE 196 TYPE REC4 (D : NATURAL := IDENT_INT (0)) IS 197 RECORD 198 A : ARR (D .. 5); 199 END RECORD; 200 END LPRIV; 201 202 PACKAGE BODY LPRIV IS 203 PROCEDURE PROC (R : REC4) IS 204 I : INTEGER; 205 BEGIN 206 I := IDENT_INT (R.A'FIRST); 207 IF EQUAL(2, IDENT_INT(1)) THEN 208 FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I)); --USE I 209 END IF; 210 END PROC; 211 END LPRIV; 212 213 USE LPRIV; 214 215 BEGIN 216 DECLARE 217 R4 : REC4; 218 219 BEGIN 220 PROC (R4); 221 FAILED ( "NO EXCEPTION RAISED AT " & 222 "DECLARATION OF R4" ); 223 EXCEPTION 224 WHEN OTHERS => 225 FAILED ( "EXCEPTION FOR R4 RAISED INSIDE " & 226 "BLOCK" ); 227 END; 228 229 EXCEPTION 230 WHEN CONSTRAINT_ERROR => 231 NULL; 232 WHEN OTHERS => 233 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & 234 "OF R4" ); 235 END; 236 237 EXCEPTION 238 WHEN CONSTRAINT_ERROR => 239 FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & 240 "DECLARATION OF REC4" ); 241 WHEN OTHERS => 242 FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & 243 "DECLARATION OF REC4" ); 244 END; 245 246 RESULT; 247END C37108B; 248