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, 0 insertions, 188 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c9/c953001.a b/gcc/testsuite/ada/acats/tests/c9/c953001.a deleted file mode 100644 index bc9c85f302f..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c953001.a +++ /dev/null @@ -1,188 +0,0 @@ --- 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; |