1-- C410001.A 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-- 26-- OBJECTIVE: 27-- Check that evaluating an access to subprogram variable containing 28-- the value null causes the exception Constraint_Error. 29-- Check that the default value for objects of access to subprogram 30-- types is null. 31-- 32-- TEST DESCRIPTION: 33-- This test defines a few simple access_to_subprogram types, and 34-- objects of those types. It checks that the default values for 35-- these objects is null, and that an attempt to make a subprogram 36-- call via one of this objects containing a null value causes the 37-- predefined exception Constraint_Error. The check is performed 38--- both with the default null value, and with an explicitly assigned 39-- null value, after the object has been used to successfully designate 40-- and call a subprogram. 41-- 42-- 43-- CHANGE HISTORY: 44-- 05 APR 96 SAIC Initial version 45-- 04 NOV 96 SAIC Revised for 2.1 release 46-- 26 FEB 97 PWB.CTA Initialized variable before passing to function 47--! 48 49----------------------------------------------------------------- C410001_0 50 51package C410001_0 is 52 53 -- used to "switch state" in the software 54 Expect_Exception : Boolean; 55 56 -- define a minimal mixture of access_to_subprogram types 57 58 type Proc_Ref is access procedure; 59 60 type Func_Ref is access function(I:Integer) return Integer; 61 62 type Proc_Para_Ref is access procedure(P:Proc_Ref); 63 64 type Func_Para_Ref is access function(F:Func_Ref) return Integer; 65 66 type Prot_Proc_Ref is access protected procedure; 67 68 type Prot_Func_Ref is access protected function return Boolean; 69 70 -- define some subprograms for them to reference 71 72 procedure Proc; 73 74 function Func(I:Integer) return Integer; 75 76 procedure Proc_Para( Param : Proc_Ref ); 77 78 function Func_Para( Param : Func_Ref ) return Integer; 79 80 protected Prot_Obj is 81 procedure Prot_Proc; 82 function Prot_Func return Boolean; 83 end Prot_Obj; 84 85end C410001_0; 86 87-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 88 89with Report; 90package body C410001_0 is 91 92 -- Note that some failing cases will cause duplicate failure messages; 93 -- rather than have the procedure/function bodies be null, the error 94 -- checking code makes for a reasonable anti-optimization feature. 95 96 procedure Proc is 97 begin 98 if Expect_Exception then 99 Report.Failed("Expected exception did not occur: Proc"); 100 end if; 101 end Proc; 102 103 function Func(I:Integer) return Integer is 104 begin 105 if Expect_Exception then 106 Report.Failed("Expected exception did not occur: Func"); 107 end if; 108 return Report.Ident_Int(I); 109 end Func; 110 111 procedure Proc_Para( Param : Proc_Ref ) is 112 begin 113 114 Param.all; -- call by explicit dereference 115 116 if Expect_Exception then 117 Report.Failed("Expected exception did not occur: Proc_Para"); 118 end if; 119 120 exception 121 when Constraint_Error => 122 if not Expect_Exception then 123 Report.Failed("Unexpected Constraint_Error: Proc_Para"); 124 end if; -- else null; expected the exception 125 when others => Report.Failed("Unexpected exception: Proc_Para"); 126 end Proc_Para; 127 128 function Func_Para( Param : Func_Ref ) return Integer is 129 begin 130 131 return Param(1); -- call by implicit dereference 132 133 if Expect_Exception then 134 Report.Failed("Expected exception did not occur: Func_Para"); 135 end if; 136 return 1; -- really just to avoid warnings 137 138 exception 139 when Constraint_Error => 140 if not Expect_Exception then 141 Report.Failed("Unexpected Constraint_Error: Func_Para"); 142 return 0; 143 else 144 return 1995; -- any value other than this is unexpected 145 end if; 146 when others => Report.Failed("Unexpected exception: Func_Para"); 147 return -42; 148 end Func_Para; 149 150 protected body Prot_Obj is 151 152 procedure Prot_Proc is 153 begin 154 if Expect_Exception then 155 Report.Failed("Expected exception did not occur: Prot_Proc"); 156 end if; 157 end Prot_Proc; 158 159 function Prot_Func return Boolean is 160 begin 161 if Expect_Exception then 162 Report.Failed("Expected exception did not occur: Prot_Func"); 163 end if; 164 return Report.Ident_Bool( True ); 165 end Prot_Func; 166 167 end Prot_Obj; 168 169end C410001_0; 170 171------------------------------------------------------------------- C410001 172 173with Report; 174with TCTouch; 175with C410001_0; 176procedure C410001 is 177 178 Proc_Ref_Var : C410001_0.Proc_Ref; 179 180 Func_Ref_Var : C410001_0.Func_Ref; 181 182 Proc_Para_Ref_Var : C410001_0.Proc_Para_Ref; 183 184 Func_Para_Ref_Var : C410001_0.Func_Para_Ref; 185 186 type Enclosure is record 187 Prot_Proc_Ref_Var : C410001_0.Prot_Proc_Ref; 188 Prot_Func_Ref_Var : C410001_0.Prot_Func_Ref; 189 end record; 190 191 Enclosed : Enclosure; 192 193 Valid_Proc : C410001_0.Proc_Ref := C410001_0.Proc'Access; 194 195 Valid_Func : C410001_0.Func_Ref := C410001_0.Func'Access; 196 197 procedure Make_Calls( Expecting_Exceptions : Boolean ) is 198 type Case_Numbers is range 1..6; 199 Some_Integer : Integer := 0; 200 begin 201 for Cases in Case_Numbers loop 202 Catch_Exception : begin 203 case Cases is 204 when 1 => Proc_Ref_Var.all; 205 when 2 => Some_Integer := Func_Ref_Var.all( Some_Integer ); 206 when 3 => Proc_Para_Ref_Var( Valid_Proc ); 207 when 4 => Some_Integer := Func_Para_Ref_Var( Valid_Func ); 208 when 5 => Enclosed.Prot_Proc_Ref_Var.all; 209 when 6 => TCTouch.Assert( Enclosed.Prot_Func_Ref_Var.all 210 /= Expecting_Exceptions, 211 "Case 6"); 212 end case; 213 if Expecting_Exceptions then 214 Report.Failed("Exception expected: Case" 215 & Case_Numbers'Image(Cases) ); 216 end if; 217 exception 218 when Constraint_Error => 219 if not Expecting_Exceptions then 220 Report.Failed("Constraint_Error not expected: Case" 221 & Case_Numbers'Image(Cases) ); 222 end if; 223 when others => 224 Report.Failed("Wrong/Bad Exception: Case" 225 & Case_Numbers'Image(Cases) ); 226 end Catch_Exception; 227 end loop; 228 end Make_Calls; 229 230begin -- Main test procedure. 231 232 Report.Test ("C410001", "Check that evaluating an access to subprogram " & 233 "variable containing the value null causes the " & 234 "exception Constraint_Error. Check that the " & 235 "default value for objects of access to " & 236 "subprogram types is null" ); 237 238 -- check that the default values are null 239 declare 240 use C410001_0; -- make all "="'s visible for all types 241 begin 242 TCTouch.Assert( Proc_Ref_Var = null, "Proc_Ref_Var = null" ); 243 244 TCTouch.Assert( Func_Ref_Var = null, "Func_Ref_Var = null" ); 245 246 TCTouch.Assert( Proc_Para_Ref_Var = null, "Proc_Para_Ref_Var = null" ); 247 248 TCTouch.Assert( Func_Para_Ref_Var = null, "Func_Para_Ref_Var = null" ); 249 250 TCTouch.Assert( Enclosed.Prot_Proc_Ref_Var = null, 251 "Enclosed.Prot_Proc_Ref_Var = null" ); 252 253 TCTouch.Assert( Enclosed.Prot_Func_Ref_Var = null, 254 "Enclosed.Prot_Func_Ref_Var = null" ); 255 end; 256 257 -- check that calls via the default values cause Constraint_Error 258 259 C410001_0.Expect_Exception := True; 260 261 Make_Calls( Expecting_Exceptions => True ); 262 263 -- assign non-null values to the objects 264 265 Proc_Ref_Var := C410001_0.Proc'Access; 266 Func_Ref_Var := C410001_0.Func'Access; 267 Proc_Para_Ref_Var := C410001_0.Proc_Para'Access; 268 Func_Para_Ref_Var := C410001_0.Func_Para'Access; 269 Enclosed := (C410001_0.Prot_Obj.Prot_Proc'Access, 270 C410001_0.Prot_Obj.Prot_Func'Access); 271 272 -- check that the calls perform normally 273 274 C410001_0.Expect_Exception := False; 275 276 Make_Calls( Expecting_Exceptions => False ); 277 278 -- check that a passed null value causes Constraint_Error 279 280 C410001_0.Expect_Exception := True; 281 282 Proc_Para_Ref_Var( null ); 283 284 TCTouch.Assert( Func_Para_Ref_Var( null ) = 1995, 285 "Func_Para_Ref_Var( null )"); 286 287 -- assign the null value to the objects 288 289 Proc_Ref_Var := null; 290 Func_Ref_Var := null; 291 Proc_Para_Ref_Var := null; 292 Func_Para_Ref_Var := null; 293 Enclosed := (null,null); 294 295 -- check that calls now again cause Constraint_Error 296 297 C410001_0.Expect_Exception := True; 298 299 Make_Calls( Expecting_Exceptions => True ); 300 301 Report.Result; 302 303end C410001; 304