1-- C954017.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 when an exception is raised in the rendezvous of a task 28-- that was called by a requeue the exception is propagated to the 29-- original caller and that the requeuing task is unaffected. 30-- 31-- TEST DESCRIPTION: 32-- The Intermediate task requeues a call from the Original_Caller to the 33-- Receiver. While the Receiver is in the accept body for this 34-- rendezvous a Constraint_Error exception is raised. Check that the 35-- exception is propagated to the Original_Caller, that the Receiver's 36-- normal exception logic is employed and that the Intermediate task 37-- is undisturbed. 38-- There are several delay loops in this test any one of which could 39-- cause it to hang (and thus fail). 40-- 41-- 42-- CHANGE HISTORY: 43-- 06 Dec 94 SAIC ACVC 2.0 44-- 25 Nov 95 SAIC Fixed shared global variable problem for 45-- ACVC 2.0.1 46-- 47--! 48 49with Report; 50with ImpDef; 51 52 53procedure C954017 is 54 55 TC_Original_Caller_Complete : Boolean := false; 56 TC_Intermediate_Complete : Boolean := false; 57 TC_Receiver_Complete : Boolean := false; 58 TC_Exception : Exception; 59 60 61 protected type Shared_Boolean (Initial_Value : Boolean := False) is 62 procedure Set_True; 63 procedure Set_False; 64 function Value return Boolean; 65 private 66 Current_Value : Boolean := Initial_Value; 67 end Shared_Boolean; 68 69 protected body Shared_Boolean is 70 procedure Set_True is 71 begin 72 Current_Value := True; 73 end Set_True; 74 75 procedure Set_False is 76 begin 77 Current_Value := False; 78 end Set_False; 79 80 function Value return Boolean is 81 begin 82 return Current_Value; 83 end Value; 84 end Shared_Boolean; 85 86 TC_Exception_Process_Complete : Shared_Boolean (False); 87 88 task Original_Caller is 89 entry Start; 90 end Original_Caller; 91 92 task Intermediate is 93 entry Input; 94 end Intermediate; 95 96 task Receiver is 97 entry Input; 98 end Receiver; 99 100 101 task body Original_Caller is 102 begin 103 accept Start; -- wait for the trigger from Main 104 105 Intermediate.Input; 106 Report.Failed ("Exception not propagated to Original_Caller"); 107 108 exception 109 when TC_Exception => 110 TC_Original_Caller_Complete := true; -- Expected behavior 111 when others => 112 Report.Failed ("Unexpected Exception in Original_Caller task"); 113 end Original_Caller; 114 115 116 task body Intermediate is 117 begin 118 accept Input do 119 -- Within this accept call another task 120 requeue Receiver.Input with abort; 121 end Input; 122 123 -- Wait for Main to ensure that the exception housekeeping is finished 124 while not TC_Exception_Process_Complete.Value loop 125 delay ImpDef.Minimum_Task_Switch; 126 end loop; 127 128 TC_Intermediate_Complete := true; 129 130 exception 131 when others => 132 Report.Failed ("Unexpected exception in Intermediate task"); 133 end Intermediate; 134 135 136 task body Receiver is 137 -- 138 begin 139 accept Input do 140 null; -- the user code for the rendezvous is stubbed out 141 142 -- Test Control: Raise an exception in the destination task which 143 -- should then be propagated 144 raise TC_Exception; 145 146 end Input; 147 exception 148 when TC_Exception => 149 TC_Receiver_Complete := true; -- expected behavior 150 when others => 151 Report.Failed ("Unexpected Exception in Receiver Task"); 152 end Receiver; 153 154 155begin 156 157 Report.Test ("C954017", "Requeue: exception processing"); 158 159 Original_Caller.Start; -- Start the test after the Report.Test 160 161 -- Wait for the whole of the exception process to complete 162 while not ( Original_Caller'terminated and Receiver'terminated ) loop 163 delay ImpDef.Minimum_Task_Switch; 164 end loop; 165 166 -- Inform the Intermediate task that the process is complete to allow 167 -- it to continue to completion itself 168 TC_Exception_Process_Complete.Set_True; 169 170 -- Wait for everything to settle before reporting the result 171 while not ( Intermediate'terminated ) loop 172 delay ImpDef.Minimum_Task_Switch; 173 end loop; 174 175 176 if not ( TC_Original_Caller_Complete and 177 TC_Intermediate_Complete and 178 TC_Receiver_Complete) then 179 Report.Failed ("Proper paths not traversed"); 180 end if; 181 182 Report.Result; 183 184end C954017; 185