1-- C46054A.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 FOR CONVERSION TO AN 26-- ACCESS SUBTYPE IF THE OPERAND VALUE IS NOT NULL AND THE 27-- DISCRIMINANTS OR INDEX BOUNDS OF THE DESIGNATED OBJECT DO NOT 28-- MATCH THOSE OF THE TARGET TYPE. 29 30-- R.WILLIAMS 9/9/86 31 32WITH REPORT; USE REPORT; 33PROCEDURE C46054A IS 34 35BEGIN 36 TEST ( "C46054A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & 37 "CONVERSION TO AN ACCESS SUBTYPE IF THE " & 38 "OPERAND VALUE IS NOT NULL AND THE " & 39 "DISCRIMINANTS OR INDEX BOUNDS OF THE " & 40 "DESIGNATED OBJECT DO NOT MATCH THOSE OF " & 41 "THE TARGET TYPE" ); 42 43 DECLARE 44 TYPE REC (D : INTEGER) IS 45 RECORD 46 NULL; 47 END RECORD; 48 49 TYPE ACREC IS ACCESS REC; 50 A : ACREC (IDENT_INT (0)) := NEW REC (IDENT_INT (0)); 51 52 SUBTYPE ACREC3 IS ACREC (IDENT_INT (3)); 53 54 PROCEDURE PROC (A : ACREC) IS 55 I : INTEGER; 56 BEGIN 57 I := IDENT_INT (A.D); 58 END PROC; 59 60 BEGIN 61 PROC (ACREC3 (A)); 62 FAILED ( "NO EXCEPTION RAISED FOR 'ACREC3 (A)'" ); 63 EXCEPTION 64 WHEN CONSTRAINT_ERROR => 65 NULL; 66 WHEN OTHERS => 67 FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC3 (A)'" ); 68 END; 69 70 DECLARE 71 TYPE REC (D1, D2 : INTEGER) IS 72 RECORD 73 NULL; 74 END RECORD; 75 76 TYPE ACREC IS ACCESS REC; 77 78 A : ACREC (IDENT_INT (3), IDENT_INT (1)) := 79 NEW REC (IDENT_INT (3), IDENT_INT (1)); 80 81 SUBTYPE ACREC13 IS ACREC (IDENT_INT (1), IDENT_INT (3)); 82 83 PROCEDURE PROC (A : ACREC) IS 84 I : INTEGER; 85 BEGIN 86 I := IDENT_INT (A.D1); 87 END PROC; 88 89 BEGIN 90 PROC (ACREC13 (A)); 91 FAILED ( "NO EXCEPTION RAISED FOR 'ACREC13 (A)'" ); 92 EXCEPTION 93 WHEN CONSTRAINT_ERROR => 94 NULL; 95 WHEN OTHERS => 96 FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC13 (A)'" ); 97 END; 98 99 DECLARE 100 TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; 101 102 TYPE ACARR IS ACCESS ARR; 103 A : ACARR (IDENT_INT (0) .. IDENT_INT (1)) := 104 NEW ARR'(IDENT_INT (0) .. IDENT_INT (1) => 0); 105 106 SUBTYPE ACARR02 IS ACARR (IDENT_INT (0) .. IDENT_INT (2)); 107 108 PROCEDURE PROC (A : ACARR) IS 109 I : INTEGER; 110 BEGIN 111 I := IDENT_INT (A'LAST); 112 END PROC; 113 114 BEGIN 115 PROC (ACARR02 (A)); 116 FAILED ( "NO EXCEPTION RAISED FOR 'ACARR02 (A)'" ); 117 EXCEPTION 118 WHEN CONSTRAINT_ERROR => 119 NULL; 120 WHEN OTHERS => 121 FAILED ( "WRONG EXCEPTION RAISED FOR 'ACARR02 (A)'" ); 122 END; 123 124 DECLARE 125 TYPE ARR IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF 126 INTEGER; 127 128 TYPE ACARR IS ACCESS ARR; 129 A : ACARR (IDENT_INT (1) .. IDENT_INT (0), 130 IDENT_INT (4) .. IDENT_INT (5)) := 131 NEW ARR'(IDENT_INT (1) .. IDENT_INT (0) => 132 (IDENT_INT (4) .. IDENT_INT (5) => 0)); 133 134 SUBTYPE NACARR IS ACARR (IDENT_INT (0) .. IDENT_INT (1), 135 IDENT_INT (5) .. IDENT_INT (4)); 136 137 PROCEDURE PROC (A : NACARR) IS 138 I : INTEGER; 139 BEGIN 140 I := IDENT_INT (A'LAST (1)); 141 END PROC; 142 143 BEGIN 144 PROC (NACARR (A)); 145 FAILED ( "NO EXCEPTION RAISED FOR 'NACARR (A)'" ); 146 EXCEPTION 147 WHEN CONSTRAINT_ERROR => 148 NULL; 149 WHEN OTHERS => 150 FAILED ( "WRONG EXCEPTION RAISED FOR 'NACARR (A)'" ); 151 END; 152 153 DECLARE 154 PACKAGE PKG1 IS 155 TYPE PRIV (D : INTEGER) IS PRIVATE; 156 TYPE ACPRV IS ACCESS PRIV; 157 SUBTYPE ACPRV3 IS ACPRV (IDENT_INT (3)); 158 159 PRIVATE 160 TYPE PRIV (D : INTEGER) IS 161 RECORD 162 NULL; 163 END RECORD; 164 END PKG1; 165 166 USE PKG1; 167 168 PACKAGE PKG2 IS 169 A : ACPRV (IDENT_INT (0)) := NEW PRIV (IDENT_INT (0)); 170 END PKG2; 171 172 USE PKG2; 173 174 PROCEDURE PROC (A : ACPRV) IS 175 I : INTEGER; 176 BEGIN 177 I := IDENT_INT (A.D); 178 END PROC; 179 180 BEGIN 181 PROC (ACPRV3 (A)); 182 FAILED ( "NO EXCEPTION RAISED FOR 'ACPRV3 (A)'" ); 183 EXCEPTION 184 WHEN CONSTRAINT_ERROR => 185 NULL; 186 WHEN OTHERS => 187 FAILED ( "WRONG EXCEPTION RAISED FOR 'ACPRV3 (A)'" ); 188 END; 189 190 RESULT; 191END C46054A; 192