diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940010.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940010.a | 269 |
1 files changed, 269 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940010.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940010.a new file mode 100644 index 000000000..c4a670552 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940010.a @@ -0,0 +1,269 @@ +-- C940010.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 an exception is raised during the execution of an +-- entry body it is propagated back to the caller +-- +-- TEST DESCRIPTION: +-- Use a small fragment of code from the simulation of a freeway meter +-- used in c940007. Create three individual tasks which will be queued on +-- the entry as the barrier is set. Release them one at a time. A +-- procedure which is called within the entry has been modified for this +-- test to raise a different exception for each pass through. Check that +-- all expected exceptions are raised and propagated. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + +procedure C940010 is + + TC_Failed_1 : Boolean := false; + +begin + + Report.Test ("C940010", "Check that an exception raised in an entry " & + "body is propagated back to the caller"); + + declare -- encapsulate the test + + TC_Defined_Error : Exception; -- User defined exception + TC_Expected_Passage_Total : constant integer := 669; + TC_Int : constant integer := 5; + + -- Carrier tasks. One is created for each vehicle arriving at each ramp + task type Vehicle_31; -- For Ramp_31 + type acc_Vehicle_31 is access Vehicle_31; + + + --================================================================ + protected Ramp_31 is + + function Meter_in_Use_State return Boolean; + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + entry Wait_at_Meter; + procedure Pulse; + -- + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + function TC_Get_Current_Exception return integer; + + private + + Release_One_Vehicle : Boolean := false; + Meter_in_Use : Boolean := true; -- TC: set true for this test + -- + TC_Multiplier : integer := 1; + TC_Passage_Total : integer := 0; + -- Use this to cycle through the required exceptions + TC_Current_Exception : integer range 0..3 := 0; + + end Ramp_31; + --================================================================ + protected body Ramp_31 is + + + -- Trace the paths through the various routines by totaling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier); + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + function TC_Get_Current_Exception return integer is + begin + return TC_Current_Exception; + end TC_Get_Current_Exception; + + + ----------------- + + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Simulate the effects of the regular signal pulse + procedure Pulse is + begin + Release_one_Vehicle := true; + end Pulse; + + -- Keep count of vehicles currently on meter queue - we can't use + -- the 'count because we need the outcall trigger + procedure Add_Meter_Queue is + begin + null; --::: stub + end Add_Meter_Queue; + + -- TC: This routine has been modified to raise the required + -- exceptions + procedure Subtract_Meter_Queue is + TC_Pass_Point1 : constant integer := 10; + TC_Pass_Point2 : constant integer := 20; + TC_Pass_Point3 : constant integer := 30; + TC_Pass_Point9 : constant integer := 1000; -- error + begin + -- Cycle through the required exceptions, one per call + TC_Current_Exception := TC_Current_Exception + 1; + case TC_Current_Exception is + when 1 => + TC_Passage (TC_Pass_Point1); -- note passage through here + raise Storage_Error; -- PREDEFINED EXCEPTION + when 2 => + TC_Passage (TC_Pass_Point2); -- note passage through here + raise TC_Defined_Error; -- USER DEFINED EXCEPTION + when 3 => + TC_Passage (TC_Pass_Point3); -- note passage through here + -- RUN TIME EXCEPTION (Constraint_Error) + -- Add the value 3 to 5 then try to assign it to an object + -- whose range is 0..3 - this causes the exception. + -- Disguise the values which cause the Constraint_Error + -- so that the optimizer will not eliminate this code + -- Note: the variable is checked at the end to ensure + -- that the actual assignment is attempted. Also note + -- the value remains at 3 as the assignment does not + -- take place. This is the value that is checked at + -- the end of the test. + -- Otherwise the optimizer could decide that the result + -- of the assignment was not used so why bother to do it? + TC_Current_Exception := + Report.Ident_Int (TC_Current_Exception) + + Report.Ident_Int (TC_Int); + when others => + -- Set flag for Report.Failed which cannot be called from + -- within a Protected Object + TC_Failed_1 := True; + end case; + + TC_Passage ( TC_Pass_Point9 ); -- note passage through here + end Subtract_Meter_Queue; + + -- Here each Vehicle task queues itself awaiting release + entry Wait_at_Meter when Release_One_Vehicle is + -- Example of entry with barriers and persistent signal + TC_Pass_Point : constant integer := 2; + begin + TC_Passage ( TC_Pass_Point ); -- note passage through here + Release_One_Vehicle := false; -- Consume the signal + -- Decrement number of vehicles on ramp + Subtract_Meter_Queue; -- Call procedure from within entry body + end Wait_at_Meter; + + end Ramp_31; + --================================================================ + + -- Carrier task. One is created for each vehicle arriving at Ramp_31 + task body Vehicle_31 is + TC_Pass_Point_1 : constant integer := 100; + TC_Pass_Point_2 : constant integer := 200; + TC_Pass_Point_3 : constant integer := 300; + begin + if Ramp_31.Meter_in_Use_State then + -- Increment count of number of vehicles on ramp + Ramp_31.Add_Meter_Queue; -- Call a protected procedure + -- which is also called from within + -- enter the meter queue + Ramp_31.Wait_at_Meter; -- Call a protected entry + Report.Failed ("Exception not propagated back"); + end if; + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when Storage_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_1 ); -- note passage + when TC_Defined_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage + when Constraint_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle_31; + + -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31 + -- and the generation of an accompanying carrier task + procedure New_Arrival_31 is + Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31; + TC_Pass_Point : constant integer := 1; + begin + Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; --::: stub + end New_arrival_31; + + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- Create three independent tasks which will queue themselves on the + -- entry. Each task will get a different exception + New_Arrival_31; + New_Arrival_31; + New_Arrival_31; + + delay ImpDef.Clear_Ready_Queue; + + -- Set the barrier condition of the entry true, releasing one task + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + if (TC_Expected_Passage_Total /= Ramp_31.TC_Get_Passage_Total) or + -- Note: We are not really interested in this next check. It is + -- here to ensure the earlier statements which raised the + -- Constraint_Error are not optimized out + (Ramp_31.TC_Get_Current_Exception /= 3) then + Report.Failed ("Unexpected paths taken"); + end if; + + end; -- declare + + if TC_Failed_1 then + Report.Failed ("Bad path through Subtract_Meter_Queue"); + end if; + + Report.Result; + +end C940010; |