1-- C64105C.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 NOT RAISED FOR ACCESS PARAMETERS 26-- IN THE FOLLOWING CIRCUMSTANCES: 27-- (1) 28-- (2) AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL 29-- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS 30-- DIFFERENT CONSTRAINTS. 31-- (3) 32-- SUBTESTS ARE: 33-- (C) CASE 2, IN OUT MODE, STATIC PRIVATE DISCRIMINANT. 34-- (D) CASE 2, OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. 35-- (E) SAME AS (C), WITH TYPE CONVERSION. 36-- (F) SAME AS (D), WITH TYPE CONVERSION. 37 38-- JRK 3/20/81 39-- SPS 10/26/82 40-- CPP 8/8/84 41 42WITH REPORT; 43PROCEDURE C64105C IS 44 45 USE REPORT; 46 47BEGIN 48 TEST ("C64105C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & 49 "AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL " & 50 "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " & 51 "DIFFERENT CONSTRAINTS" ); 52 53 -------------------------------------------------- 54 55 DECLARE -- (C) 56 57 PACKAGE PKG IS 58 TYPE E IS (E1, E2); 59 TYPE T (D : E := E1) IS PRIVATE; 60 PRIVATE 61 TYPE T (D : E := E1) IS 62 RECORD 63 I : INTEGER; 64 CASE D IS 65 WHEN E1 => 66 B : BOOLEAN; 67 WHEN E2 => 68 C : CHARACTER; 69 END CASE; 70 END RECORD; 71 END PKG; 72 USE PKG; 73 74 TYPE A IS ACCESS T; 75 SUBTYPE SA IS A(E2); 76 V : A (E1) := NULL; 77 ENTERED : BOOLEAN := FALSE; 78 79 PROCEDURE P (X : IN OUT SA) IS 80 BEGIN 81 ENTERED := TRUE; 82 X := NULL; 83 EXCEPTION 84 WHEN OTHERS => 85 FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)"); 86 END P; 87 88 BEGIN -- (C) 89 90 P (V); 91 92 EXCEPTION 93 WHEN CONSTRAINT_ERROR => 94 IF NOT ENTERED THEN 95 FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); 96 ELSE 97 FAILED ("EXCEPTION RAISED ON RETURN - (C)"); 98 END IF; 99 WHEN OTHERS => 100 FAILED ("EXCEPTION RAISED - (C)"); 101 END; -- (C) 102 103 -------------------------------------------------- 104 105 DECLARE -- (D) 106 107 TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF 108 INTEGER; 109 110 TYPE A IS ACCESS T; 111 SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); 112 V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), 113 IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; 114 ENTERED : BOOLEAN := FALSE; 115 116 PROCEDURE P (X : OUT SA) IS 117 BEGIN 118 ENTERED := TRUE; 119 X := NULL; 120 EXCEPTION 121 WHEN OTHERS => 122 FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)"); 123 END P; 124 125 BEGIN -- (D) 126 127 P (V); 128 129 EXCEPTION 130 WHEN CONSTRAINT_ERROR => 131 IF NOT ENTERED THEN 132 FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); 133 ELSE 134 FAILED ("EXCEPTION RAISED ON RETURN - (D)"); 135 END IF; 136 WHEN OTHERS => 137 FAILED ("EXCEPTION RAISED - (D)"); 138 END; -- (D) 139 140 -------------------------------------------------- 141 142 DECLARE -- (E) 143 144 PACKAGE PKG IS 145 TYPE E IS (E1, E2); 146 TYPE T (D : E := E1) IS PRIVATE; 147 PRIVATE 148 TYPE T (D : E := E1) IS 149 RECORD 150 I : INTEGER; 151 CASE D IS 152 WHEN E1 => 153 B : BOOLEAN; 154 WHEN E2 => 155 C : CHARACTER; 156 END CASE; 157 END RECORD; 158 END PKG; 159 USE PKG; 160 161 TYPE A IS ACCESS T; 162 SUBTYPE SA IS A(E2); 163 V : A (E1) := NULL; 164 ENTERED : BOOLEAN := FALSE; 165 166 PROCEDURE P (X : IN OUT SA) IS 167 BEGIN 168 ENTERED := TRUE; 169 X := NULL; 170 EXCEPTION 171 WHEN OTHERS => 172 FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)"); 173 END P; 174 175 BEGIN -- (E) 176 177 P (SA(V)); 178 179 EXCEPTION 180 WHEN CONSTRAINT_ERROR => 181 IF NOT ENTERED THEN 182 FAILED ("EXCEPTION RAISED BEFORE CALL - (E)"); 183 ELSE 184 FAILED ("EXCEPTION RAISED ON RETURN - (E)"); 185 END IF; 186 WHEN OTHERS => 187 FAILED ("EXCEPTION RAISED - (E)"); 188 END; -- (E) 189 190 -------------------------------------------------- 191 192 DECLARE -- (F) 193 194 TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF 195 INTEGER; 196 197 TYPE A IS ACCESS T; 198 SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); 199 V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), 200 IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; 201 ENTERED : BOOLEAN := FALSE; 202 203 PROCEDURE P (X : OUT SA) IS 204 BEGIN 205 ENTERED := TRUE; 206 X := NULL; 207 EXCEPTION 208 WHEN OTHERS => 209 FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)"); 210 END P; 211 212 BEGIN -- (D) 213 214 P (SA(V)); 215 216 EXCEPTION 217 WHEN CONSTRAINT_ERROR => 218 IF NOT ENTERED THEN 219 FAILED ("EXCEPTION RAISED BEFORE CALL - (F)"); 220 ELSE 221 FAILED ("EXCEPTION RAISED ON RETURN - (F)"); 222 END IF; 223 WHEN OTHERS => 224 FAILED ("EXCEPTION RAISED - (F)"); 225 END; -- (F) 226 227 -------------------------------------------------- 228 229 RESULT; 230END C64105C; 231