URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c9/] [c954017.a] - Rev 149
Go to most recent revision | Compare with Previous | Blame | View Log
-- C954017.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that when an exception is raised in the rendezvous of a task
-- that was called by a requeue the exception is propagated to the
-- original caller and that the requeuing task is unaffected.
--
-- TEST DESCRIPTION:
-- The Intermediate task requeues a call from the Original_Caller to the
-- Receiver. While the Receiver is in the accept body for this
-- rendezvous a Constraint_Error exception is raised. Check that the
-- exception is propagated to the Original_Caller, that the Receiver's
-- normal exception logic is employed and that the Intermediate task
-- is undisturbed.
-- There are several delay loops in this test any one of which could
-- cause it to hang (and thus fail).
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 25 Nov 95 SAIC Fixed shared global variable problem for
-- ACVC 2.0.1
--
--!
with Report;
with ImpDef;
procedure C954017 is
TC_Original_Caller_Complete : Boolean := false;
TC_Intermediate_Complete : Boolean := false;
TC_Receiver_Complete : Boolean := false;
TC_Exception : Exception;
protected type Shared_Boolean (Initial_Value : Boolean := False) is
procedure Set_True;
procedure Set_False;
function Value return Boolean;
private
Current_Value : Boolean := Initial_Value;
end Shared_Boolean;
protected body Shared_Boolean is
procedure Set_True is
begin
Current_Value := True;
end Set_True;
procedure Set_False is
begin
Current_Value := False;
end Set_False;
function Value return Boolean is
begin
return Current_Value;
end Value;
end Shared_Boolean;
TC_Exception_Process_Complete : Shared_Boolean (False);
task Original_Caller is
entry Start;
end Original_Caller;
task Intermediate is
entry Input;
end Intermediate;
task Receiver is
entry Input;
end Receiver;
task body Original_Caller is
begin
accept Start; -- wait for the trigger from Main
Intermediate.Input;
Report.Failed ("Exception not propagated to Original_Caller");
exception
when TC_Exception =>
TC_Original_Caller_Complete := true; -- Expected behavior
when others =>
Report.Failed ("Unexpected Exception in Original_Caller task");
end Original_Caller;
task body Intermediate is
begin
accept Input do
-- Within this accept call another task
requeue Receiver.Input with abort;
end Input;
-- Wait for Main to ensure that the exception housekeeping is finished
while not TC_Exception_Process_Complete.Value loop
delay ImpDef.Minimum_Task_Switch;
end loop;
TC_Intermediate_Complete := true;
exception
when others =>
Report.Failed ("Unexpected exception in Intermediate task");
end Intermediate;
task body Receiver is
--
begin
accept Input do
null; -- the user code for the rendezvous is stubbed out
-- Test Control: Raise an exception in the destination task which
-- should then be propagated
raise TC_Exception;
end Input;
exception
when TC_Exception =>
TC_Receiver_Complete := true; -- expected behavior
when others =>
Report.Failed ("Unexpected Exception in Receiver Task");
end Receiver;
begin
Report.Test ("C954017", "Requeue: exception processing");
Original_Caller.Start; -- Start the test after the Report.Test
-- Wait for the whole of the exception process to complete
while not ( Original_Caller'terminated and Receiver'terminated ) loop
delay ImpDef.Minimum_Task_Switch;
end loop;
-- Inform the Intermediate task that the process is complete to allow
-- it to continue to completion itself
TC_Exception_Process_Complete.Set_True;
-- Wait for everything to settle before reporting the result
while not ( Intermediate'terminated ) loop
delay ImpDef.Minimum_Task_Switch;
end loop;
if not ( TC_Original_Caller_Complete and
TC_Intermediate_Complete and
TC_Receiver_Complete) then
Report.Failed ("Proper paths not traversed");
end if;
Report.Result;
end C954017;
Go to most recent revision | Compare with Previous | Blame | View Log