1-- C37006A.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-- FOR A COMPONENT OF A RECORD, ACCESS, OR PRIVATE TYPE, OR FOR A 26-- LIMITED PRIVATE COMPONENT, CHECK THAT A NON-STATIC EXPRESSION CAN 27-- BE USED IN A DISCRIMINANT CONSTRAINT OR (EXCEPTING LIMITED PRIVATE 28-- COMPONENTS) IN SPECIFYING A DEFAULT INITIAL VALUE. 29 30-- R.WILLIAMS 8/28/86 31 32WITH REPORT; USE REPORT; 33PROCEDURE C37006A IS 34 35 SUBTYPE INT IS INTEGER RANGE 0 .. 100; 36 37 TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER; 38 39 TYPE REC1 (D1, D2 : INT) IS 40 RECORD 41 A : ARR (D1 .. D2); 42 END RECORD; 43 44 TYPE REC1_NAME IS ACCESS REC1; 45 46 PROCEDURE CHECK (AR : ARR; STR : STRING) IS 47 BEGIN 48 IF AR'FIRST /= 1 OR AR'LAST /= 2 THEN 49 FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN COMPONENT " & 50 "OF " & STR & " TYPE"); 51 ELSIF AR /= (3, 4) THEN 52 FAILED ( "INITIALIZATION OF R.COMP.A IN COMPONENT OF " & 53 STR & " TYPE FAILED" ); 54 END IF; 55 END CHECK; 56 57 PACKAGE PACK IS 58 TYPE PRIV (D1, D2 : INT) IS PRIVATE; 59 TYPE LIM (D1, D2 : INT) IS LIMITED PRIVATE; 60 FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV; 61 PROCEDURE PRIV_CHECK (R : PRIV); 62 PROCEDURE LIM_CHECK (R : LIM); 63 64 PRIVATE 65 TYPE PRIV (D1, D2 : INT) IS 66 RECORD 67 A : ARR (D1 .. D2); 68 END RECORD; 69 70 TYPE LIM (D1, D2 : INT) IS 71 RECORD 72 A : ARR (D1 .. D2); 73 END RECORD; 74 END PACK; 75 76 PACKAGE BODY PACK IS 77 78 FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV IS 79 BEGIN 80 RETURN (IDENT_INT (1), IDENT_INT (2), 81 ARR'(1 => 3, 2 => 4)); 82 END PRIV_FUN; 83 84 PROCEDURE PRIV_CHECK (R : PRIV) IS 85 BEGIN 86 CHECK (R.A, "PRIVATE TYPE" ); 87 END PRIV_CHECK; 88 89 PROCEDURE LIM_CHECK (R : LIM) IS 90 BEGIN 91 IF R.A'FIRST /= 1 OR R.A'LAST /= 2 THEN 92 FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN " & 93 "COMPONENT OF LIMITED PRIVATE TYPE"); 94 END IF; 95 END LIM_CHECK; 96 END PACK; 97 98 USE PACK; 99 100BEGIN 101 102 TEST ( "C37006A", "FOR A COMPONENT OF A RECORD, ACCESS, " & 103 "OR PRIVATE TYPE, OR FOR A LIMITED PRIVATE " & 104 "COMPONENT, CHECK THAT A NON-STATIC " & 105 "EXPRESSION CAN BE USED IN A DISCRIMINANT " & 106 "CONSTRAINT OR (EXCEPTING LIMITED PRIVATE " & 107 "COMPONENTS) IN SPECIFYING A DEFAULT " & 108 "INITIAL VALUE" ); 109 110 BEGIN 111 DECLARE 112 113 TYPE REC2 IS 114 RECORD 115 COMP : REC1 (IDENT_INT (1), IDENT_INT (2)) := 116 (IDENT_INT (1), IDENT_INT (2), 117 ARR'(1 => 3, 2 => 4)); 118 END RECORD; 119 120 R : REC2; 121 122 BEGIN 123 IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN 124 CHECK (R.COMP.A, "RECORD"); 125 ELSE 126 FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & 127 "OF RECORD TYPE COMPONENT" ); 128 END IF; 129 130 EXCEPTION 131 WHEN CONSTRAINT_ERROR => 132 FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & 133 "SEQUENCE FOLLOWING DECLARATION OF " & 134 "RECORD TYPE COMPONENT" ); 135 WHEN OTHERS => 136 FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & 137 "SEQUENCE FOLLOWING DECLARATION OF " & 138 "RECORD TYPE COMPONENT" ); 139 END; 140 141 EXCEPTION 142 WHEN CONSTRAINT_ERROR => 143 FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & 144 "OF RECORD TYPE COMPONENT" ); 145 WHEN OTHERS => 146 FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & 147 "OF RECORD TYPE COMPONENT" ); 148 END; 149 150 BEGIN 151 DECLARE 152 153 TYPE REC2 IS 154 RECORD 155 COMP : REC1_NAME (IDENT_INT (1), 156 IDENT_INT (2)) := 157 NEW REC1'(IDENT_INT (1), 158 IDENT_INT (2), 159 ARR'(1 => 3, 2 => 4)); 160 END RECORD; 161 162 R : REC2; 163 164 BEGIN 165 IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN 166 CHECK (R.COMP.A, "ACCESS"); 167 ELSE 168 FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & 169 "OF ACCESS TYPE COMPONENT" ); 170 END IF; 171 172 EXCEPTION 173 WHEN CONSTRAINT_ERROR => 174 FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & 175 "SEQUENCE FOLLOWING DECLARATION OF " & 176 "ACCESS TYPE COMPONENT" ); 177 WHEN OTHERS => 178 FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & 179 "SEQUENCE FOLLOWING DECLARATION OF " & 180 "ACCESS TYPE COMPONENT" ); 181 END; 182 183 EXCEPTION 184 WHEN CONSTRAINT_ERROR => 185 FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & 186 "OF ACCESS TYPE COMPONENT" ); 187 WHEN OTHERS => 188 FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & 189 "OF ACCESS TYPE COMPONENT" ); 190 END; 191 192 BEGIN 193 DECLARE 194 195 TYPE REC2 IS 196 RECORD 197 COMP : PRIV (IDENT_INT (1), IDENT_INT (2)) := 198 PRIV_FUN (IDENT_INT (1), 199 IDENT_INT (2)); 200 END RECORD; 201 202 R : REC2; 203 204 BEGIN 205 IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN 206 PRIV_CHECK (R.COMP); 207 ELSE 208 FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & 209 "OF PRIVATE TYPE COMPONENT" ); 210 END IF; 211 212 EXCEPTION 213 WHEN CONSTRAINT_ERROR => 214 FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & 215 "SEQUENCE FOLLOWING DECLARATION OF " & 216 "PRIVATE TYPE COMPONENT" ); 217 WHEN OTHERS => 218 FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & 219 "SEQUENCE FOLLOWING DECLARATION OF " & 220 "PRIVATE TYPE COMPONENT" ); 221 END; 222 223 EXCEPTION 224 WHEN CONSTRAINT_ERROR => 225 FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & 226 "OF PRIVATE TYPE COMPONENT" ); 227 WHEN OTHERS => 228 FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & 229 "OF PRIVATE TYPE COMPONENT" ); 230 END; 231 232 BEGIN 233 DECLARE 234 235 TYPE REC2 IS 236 RECORD 237 COMP : LIM (IDENT_INT (1), IDENT_INT (2)); 238 END RECORD; 239 240 R : REC2; 241 242 BEGIN 243 IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN 244 LIM_CHECK (R.COMP); 245 ELSE 246 FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & 247 "OF LIM PRIV TYPE COMPONENT" ); 248 END IF; 249 250 EXCEPTION 251 WHEN CONSTRAINT_ERROR => 252 FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & 253 "SEQUENCE FOLLOWING DECLARATION OF " & 254 " LIM PRIV TYPE COMPONENT" ); 255 WHEN OTHERS => 256 FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & 257 "SEQUENCE FOLLOWING DECLARATION OF " & 258 " LIM PRIV TYPE COMPONENT" ); 259 END; 260 261 EXCEPTION 262 WHEN CONSTRAINT_ERROR => 263 FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & 264 "OF LIM PRIV TYPE COMPONENT" ); 265 WHEN OTHERS => 266 FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & 267 "OF LIM PRIV TYPE COMPONENT" ); 268 END; 269 270 RESULT; 271 272END C37006A; 273