URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c9/] [c953001.a] - Rev 384
Compare with Previous | Blame | View Log
-- C953001.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 if the evaluation of an entry_barrier condition
-- propagates an exception, the exception Program_Error
-- is propagated to all current callers of all entries of the
-- protected object.
--
-- TEST DESCRIPTION:
-- This test declares a protected object (PO) with two entries and
-- a 5 element entry family.
-- All the entries are always closed. However, one of the entries
-- (Oh_No) will get a constraint_error in its barrier_evaluation
-- whenever the global variable Blow_Up is true.
-- An array of tasks is created where the tasks wait on the various
-- entries of the protected object. Once all the tasks are waiting
-- the main procedure calls the entry Oh_No and causes an exception
-- to be propagated to all the tasks. The tasks record the fact
-- that they got the correct exception in global variables that
-- can be checked after the tasks complete.
--
--
-- CHANGE HISTORY:
-- 19 OCT 95 SAIC ACVC 2.1
--
--!
with Report;
with ImpDef;
procedure C953001 is
Verbose : constant Boolean := False;
Max_Tasks : constant := 12;
-- note status and error conditions
Blocked_Entry_Taken : Boolean := False;
In_Oh_No : Boolean := False;
Task_Passed : array (1..Max_Tasks) of Boolean := (1..Max_Tasks => False);
begin
Report.Test ("C953001",
"Check that an exception in an entry_barrier condition" &
" causes Program_Error to be propagated to all current" &
" callers of all entries of the protected object");
declare -- test encapsulation
-- miscellaneous values
Cows : Integer := Report.Ident_Int (1);
Came_Home : Integer := Report.Ident_Int (2);
-- make the Barrier_Condition fail only when we want it to
Blow_Up : Boolean := False;
function Barrier_Condition return Boolean is
begin
if Blow_Up then
return 5 mod Report.Ident_Int(0) = 1;
else
return False;
end if;
end Barrier_Condition;
subtype Family_Index is Integer range 1..5;
protected PO is
entry Block1;
entry Oh_No;
entry Family (Family_Index);
end PO;
protected body PO is
entry Block1 when Report.Ident_Int(0) = Report.Ident_Int(1) is
begin
Blocked_Entry_Taken := True;
end Block1;
-- barrier will get a Constraint_Error (divide by 0)
entry Oh_No when Barrier_Condition is
begin
In_Oh_No := True;
end Oh_No;
entry Family (for Member in Family_Index) when Cows = Came_Home is
begin
Blocked_Entry_Taken := True;
end Family;
end PO;
task type Waiter is
entry Take_Id (Id : Integer);
end Waiter;
Bunch_of_Waiters : array (1..Max_Tasks) of Waiter;
task body Waiter is
Me : Integer;
Action : Integer;
begin
accept Take_Id (Id : Integer) do
Me := Id;
end Take_Id;
Action := Me mod (Family_Index'Last + 1);
begin
if Action = 0 then
PO.Block1;
else
PO.Family (Action);
end if;
Report.Failed ("no exception for task" & Integer'Image (Me));
exception
when Program_Error =>
Task_Passed (Me) := True;
if Verbose then
Report.Comment ("pass for task" & Integer'Image (Me));
end if;
when others =>
Report.Failed ("wrong exception raised in task" &
Integer'Image (Me));
end;
end Waiter;
begin -- test encapsulation
for I in 1..Max_Tasks loop
Bunch_Of_Waiters(I).Take_Id (I);
end loop;
-- give all the Waiters time to get queued
delay 2*ImpDef.Clear_Ready_Queue;
-- cause the protected object to fail
begin
Blow_Up := True;
PO.Oh_No;
Report.Failed ("no exception in call to PO.Oh_No");
exception
when Constraint_Error =>
Report.Failed ("Constraint_Error instead of Program_Error");
when Program_Error =>
if Verbose then
Report.Comment ("main exception passed");
end if;
when others =>
Report.Failed ("wrong exception in main");
end;
end; -- test encapsulation
-- all the tasks have now completed.
-- check the flags for pass/fail info
if Blocked_Entry_Taken then
Report.Failed ("blocked entry taken");
end if;
if In_Oh_No then
Report.Failed ("entry taken with exception in barrier");
end if;
for I in 1..Max_Tasks loop
if not Task_Passed (I) then
Report.Failed ("task" & Integer'Image (I) & " did not pass");
end if;
end loop;
Report.Result;
end C953001;