1-- CB20003.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 exceptions can be raised, reraised, and handled in an 28-- accessed subprogram. 29-- 30-- 31-- TEST DESCRIPTION: 32-- Declare a record type, with one component being an access to 33-- subprogram type. Various subprograms are defined to fit the profile 34-- of this access type, such that the record component can refer to 35-- any of the subprograms. 36-- 37-- Each of the subprograms raises a different exception, based on the 38-- value of an input parameter. Exceptions are 1) raised, handled with 39-- an others handler, reraised and propagated to main to be handled in 40-- a specific handler; 2) raised, handled in a specific handler, reraised 41-- and propagated to the main to be handled in an others handler there, 42-- and 3) raised and propagated directly to the caller by the subprogram. 43-- 44-- Boolean variables are set throughout the test to ensure that correct 45-- exception processing has occurred, and these variables are verified at 46-- the conclusion of the test. 47-- 48-- 49-- CHANGE HISTORY: 50-- 06 Dec 94 SAIC ACVC 2.0 51-- 52--! 53 54package CB20003_0 is -- package Push_Buttons 55 56 57 Non_Default_Priority, 58 Non_Alert_Priority, 59 Non_Emergency_Priority : exception; 60 61 Handled_With_Others, 62 Reraised_In_Subprogram, 63 Handled_In_Caller : Boolean := False; 64 65 subtype Priority_Type is Integer range 1 .. 10; 66 67 Default_Priority : Priority_Type := 1; 68 Alert_Priority : Priority_Type := 3; 69 Emergency_Priority : Priority_Type := 5; 70 71 72 type Button is tagged private; -- Private tagged type. 73 74 type Button_Response_Ptr is access procedure (P : in Priority_Type; 75 B : in out Button); 76 77 78 -- Procedures accessible with Button_Response_Ptr type. 79 80 procedure Default_Response (P : in Priority_Type; 81 B : in out Button); 82 83 procedure Alert_Response (P : in Priority_Type; 84 B : in out Button); 85 86 procedure Emergency_Response (P : in Priority_Type; 87 B : in out Button); 88 89 90 91 procedure Push (B : in out Button; 92 P : in Priority_Type); 93 94 procedure Set_Response (B : in out Button; 95 R : in Button_Response_Ptr); 96 97private 98 99 type Button is tagged 100 record 101 Priority : Priority_Type := Default_Priority; 102 Response : Button_Response_Ptr := Default_Response'Access; 103 end record; 104 105 106end CB20003_0; -- package Push_Buttons 107 108 109 --=================================================================-- 110 111 112with Report; 113 114package body CB20003_0 is -- package Push_Buttons 115 116 117 procedure Push (B : in out Button; 118 P : in Priority_Type) is 119 begin -- Invoking subprogram designated 120 B.Response (P, B); -- by access value. 121 end Push; 122 123 124 procedure Set_Response (B : in out Button; 125 R : in Button_Response_Ptr) is 126 begin 127 B.Response := R; -- Set procedure value in record 128 end Set_Response; 129 130 131 procedure Default_Response (P : in Priority_Type; 132 B : in out Button) is 133 begin 134 if (P > Default_Priority) then 135 raise Non_Default_Priority; 136 Report.Failed ("Exception not raised in procedure body"); 137 else 138 B.Priority := P; 139 end if; 140 exception 141 when others => -- Catch exception with others handler 142 Handled_With_Others := True; -- Successfully caught with "others" 143 raise; 144 Report.Failed ("Exception not reraised in handler"); 145 end Default_Response; 146 147 148 149 procedure Alert_Response (P : in Priority_Type; 150 B : in out Button) is 151 begin 152 if (P > Alert_Priority) then 153 raise Non_Alert_Priority; 154 Report.Failed ("Exception not raised in procedure body"); 155 else 156 B.Priority := P; 157 end if; 158 exception 159 when Non_Alert_Priority => 160 Reraised_In_Subprogram := True; 161 raise; -- Propagate to caller. 162 Report.Failed ("Exception not reraised in procedure excpt handler"); 163 when others => 164 Report.Failed ("Incorrect exception raised/handled"); 165 end Alert_Response; 166 167 168 169 procedure Emergency_Response (P : in Priority_type; 170 B : in out Button) is 171 begin 172 if (P > Emergency_Priority) then 173 raise Non_Emergency_Priority; 174 Report.Failed ("Exception not raised in procedure body"); 175 else 176 B.Priority := P; 177 end if; 178 -- No exception handler here, exception will be propagated to caller. 179 end Emergency_Response; 180 181 182end CB20003_0; -- package Push_Buttons 183 184 185 --=================================================================-- 186 187 188with Report; 189with CB20003_0; -- package Push_Buttons 190 191procedure CB20003 is 192 193 package Push_Buttons renames CB20003_0; 194 195 Console_Button : Push_Buttons.Button; 196 197begin 198 199 Report.Test ("CB20003", "Check that exceptions can be raised, " & 200 "reraised, and handled in a subprogram " & 201 "referenced by an access to subprogram value"); 202 203 204 Default_Response_Processing: -- The exception 205 -- Handled_With_Others is to 206 -- be caught with an others 207 -- handler in Default_Resp., 208 -- reraised, and handled with 209 -- a specific handler here. 210 begin 211 212 Push_Buttons.Push (Console_Button, -- Raise exception that will 213 Report.Ident_Int(2)); -- be handled in procedure. 214 exception 215 when Push_Buttons.Non_Default_Priority => 216 if not Push_Buttons.Handled_With_Others then -- Not reraised in 217 -- procedure. 218 Report.Failed 219 ("Exception not handled/reraised in procedure"); 220 end if; 221 when others => 222 Report.Failed ("Exception handled in " & 223 " Default_Response_Processing block"); 224 end Default_Response_Processing; 225 226 227 228 Alert_Response_Processing: 229 begin 230 231 Push_Buttons.Set_Response (Console_Button, 232 Push_Buttons.Alert_Response'access); 233 234 Push_Buttons.Push (Console_Button, -- Raise exception that will 235 Report.Ident_Int(4)); -- be handled in procedure, 236 -- reraised, and propagated 237 -- to caller. 238 Report.Failed ("Exception not propagated to caller " & 239 "in Alert_Response_Processing block"); 240 241 exception 242 when Push_Buttons.Non_Alert_Priority => 243 if not Push_Buttons.Reraised_In_Subprogram then -- Not reraised in 244 -- procedure. 245 Report.Failed ("Exception not reraised in procedure"); 246 end if; 247 when others => 248 Report.Failed ("Exception handled in " & 249 " Alert_Response_Processing block"); 250 end Alert_Response_Processing; 251 252 253 254 Emergency_Response_Processing: 255 begin 256 257 Push_Buttons.Set_Response (Console_Button, 258 Push_Buttons.Emergency_Response'access); 259 260 Push_Buttons.Push (Console_Button, -- Raise exception that will 261 Report.Ident_Int(6)); -- be propagated directly to 262 -- caller. 263 Report.Failed ("Exception not propagated to caller " & 264 "in Emergency_Response_Processing block"); 265 266 exception 267 when Push_Buttons.Non_Emergency_Priority => 268 Push_Buttons.Handled_In_Caller := True; 269 when others => 270 Report.Failed ("Exception handled in " & 271 " Emergency_Response_Processing block"); 272 end Emergency_Response_Processing; 273 274 275 276 if not (Push_Buttons.Handled_With_Others and 277 Push_Buttons.Reraised_In_Subprogram and 278 Push_Buttons.Handled_In_Caller ) 279 then 280 Report.Failed ("Incorrect exception handling in referenced subprograms"); 281 end if; 282 283 284 Report.Result; 285 286end CB20003; 287