diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c9/c953001.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c9/c953001.a | 188 |
1 files changed, 188 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c9/c953001.a b/gcc/testsuite/ada/acats/tests/c9/c953001.a new file mode 100644 index 000000000..bc9c85f30 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c953001.a @@ -0,0 +1,188 @@ +-- 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; |