diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cb')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb10002.a | 128 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb20001.a | 228 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb20003.a | 286 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb20004.a | 203 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb20005.a | 210 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb20006.a | 217 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb20007.a | 196 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb20a02.a | 155 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb40005.a | 339 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb40a01.a | 135 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb40a020.a | 95 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb40a030.a | 105 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb40a04.a | 119 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb41001.a | 213 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb41002.a | 283 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb41003.a | 358 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cb/cb41004.a | 316 |
17 files changed, 0 insertions, 3586 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb10002.a b/gcc/testsuite/ada/acats/tests/cb/cb10002.a deleted file mode 100644 index f3099d4a26c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb10002.a +++ /dev/null @@ -1,128 +0,0 @@ --- CB10002.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 Storage_Error is raised when storage for allocated objects --- is exceeded. --- --- TEST DESCRIPTION: --- This test allocates a very large data structure. --- --- In order to avoid running forever on virtual memory targets, the --- data structure is bounded in size, and elements are larger the longer --- the program runs. --- --- The program attempts to allocate about 8,600,000 integers, or about --- 32 Megabytes on a typical 32-bit machine. --- --- If Storage_Error is raised, the data structure is deallocated. --- (Otherwise, Report.Result may fail as memory is exhausted). - --- CHANGE HISTORY: --- 30 Aug 85 JRK Ada 83 test created. --- 14 Sep 99 RLB Created Ada 95 test. - - -with Report; -with Ada.Unchecked_Deallocation; -procedure CB10002 is - - type Data_Space is array (Positive range <>) of Integer; - - type Element (Size : Positive); - - type Link is access Element; - - type Element (Size : Positive) is - record - Parent : Link; - Child : Link; - Sibling: Link; - Data : Data_Space (1 .. Size); - end record; - - procedure Free is new Ada.Unchecked_Deallocation (Element, Link); - - Holder : array (1 .. 430) of Link; - Last_Allocated : Natural := 0; - - procedure Allocator (Count : in Positive) is - begin - -- Allocate various sized objects similar to what a real application - -- would do. - if Count in 1 .. 20 then - Holder(Count) := new Element (Report.Ident_Int(10)); - elsif Count in 21 .. 40 then - Holder(Count) := new Element (Report.Ident_Int(79)); - elsif Count in 41 .. 60 then - Holder(Count) := new Element (Report.Ident_Int(250)); - elsif Count in 61 .. 80 then - Holder(Count) := new Element (Report.Ident_Int(520)); - elsif Count in 81 .. 100 then - Holder(Count) := new Element (Report.Ident_Int(1000)); - elsif Count in 101 .. 120 then - Holder(Count) := new Element (Report.Ident_Int(2048)); - elsif Count in 121 .. 140 then - Holder(Count) := new Element (Report.Ident_Int(4200)); - elsif Count in 141 .. 160 then - Holder(Count) := new Element (Report.Ident_Int(7999)); - elsif Count in 161 .. 180 then - Holder(Count) := new Element (Report.Ident_Int(15000)); - else -- 181..430 - Holder(Count) := new Element (Report.Ident_Int(32000)); - end if; - Last_Allocated := Count; - end Allocator; - - -begin - Report.Test ("CB10002", "Check that Storage_Error is raised when " & - "storage for allocated objects is exceeded"); - - begin - for I in Holder'range loop - Allocator (I); - end loop; - Report.Not_Applicable ("Unable to exhaust memory"); - for I in 1 .. Last_Allocated loop - Free (Holder(I)); - end loop; - exception - when Storage_Error => - if Last_Allocated = 0 then - Report.Failed ("Unable to allocate anything"); - else -- Clean up, so we have enough memory to report on the result. - for I in 1 .. Last_Allocated loop - Free (Holder(I)); - end loop; - Report.Comment (Natural'Image(Last_Allocated) & " items allocated"); - end if; - when others => - Report.Failed ("Wrong exception raised by heap overflow"); - end; - - Report.Result; - -end CB10002; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20001.a b/gcc/testsuite/ada/acats/tests/cb/cb20001.a deleted file mode 100644 index ccfad52e41e..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb20001.a +++ /dev/null @@ -1,228 +0,0 @@ --- CB20001.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 exceptions can be handled in accept bodies, and that a --- task object that has an exception handled in an accept body is still --- viable for future use. --- --- TEST DESCRIPTION: --- Declare a task that has exception handlers within an accept --- statement in the task body. Declare a task object, and make entry --- calls with data that will cause various exceptions to be raised --- by the accept statement. Ensure that the exceptions are: --- 1) raised and handled locally in the accept body --- 2) raised in the accept body and handled/reraised to be handled --- by the task body --- 3) raised in the accept body and propagated to the calling --- procedure. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Report; - -package CB20001_0 is - - Incorrect_Data, - Location_Error, - Off_Screen_Data : exception; - - TC_Handled_In_Accept, - TC_Reraised_In_Accept, - TC_Handled_In_Task_Block, - TC_Handled_In_Caller : boolean := False; - - type Location_Type is range 0 .. 2000; - - task type Submarine_Type is - entry Contact (Location : in Location_Type); - end Submarine_Type; - - Current_Position : Location_Type := 0; - -end CB20001_0; - - - --=================================================================-- - - -package body CB20001_0 is - - - task body Submarine_Type is - begin - loop - - Task_Block: - begin - select - accept Contact (Location : in Location_Type) do - if Location > 1000 then - raise Off_Screen_Data; - elsif (Location > 500) and (Location <= 1000) then - raise Location_Error; - elsif (Location > 100) and (Location <= 500) then - raise Incorrect_Data; - else - Current_Position := Location; - end if; - exception - when Off_Screen_Data => - TC_Handled_In_Accept := True; - when Location_Error => - TC_Reraised_In_Accept := True; - raise; -- Reraise the Location_Error exception - -- in the task block. - end Contact; - or - terminate; - end select; - - exception - - when Off_Screen_Data => - TC_Handled_In_Accept := False; - Report.Failed ("Off_Screen_Data exception " & - "improperly handled in task block"); - - when Location_Error => - TC_Handled_In_Task_Block := True; - end Task_Block; - - end loop; - - exception - - when Location_Error | Off_Screen_Data => - TC_Handled_In_Accept := False; - TC_Handled_In_Task_Block := False; - Report.Failed ("Exception improperly propagated out to task body"); - when others => - null; - end Submarine_Type; - -end CB20001_0; - - - --=================================================================-- - - -with CB20001_0; -with Report; -with ImpDef; - -procedure CB20001 is - - package Submarine_Tracking renames CB20001_0; - - Trident : Submarine_Tracking.Submarine_Type; -- Declare task - Sonar_Contact : Submarine_Tracking.Location_Type; - - TC_LEB_Error, - TC_Main_Handler_Used : Boolean := False; - -begin - - Report.Test ("CB20001", "Check that exceptions can be handled " & - "in accept bodies"); - - - Off_Screen_Block: - begin - Sonar_Contact := 1500; - Trident.Contact (Sonar_Contact); -- Cause Off_Screen_Data exception - -- to be raised and handled in a task - -- accept body. - exception - when Submarine_Tracking.Off_Screen_Data => - TC_Main_Handler_Used := True; - Report.Failed ("Off_Screen_Data exception improperly handled " & - "in calling procedure"); - when others => - Report.Failed ("Exception handled unexpectedly in " & - "Off_Screen_Block"); - end Off_Screen_Block; - - - Location_Error_Block: - begin - Sonar_Contact := 700; - Trident.Contact (Sonar_Contact); -- Cause Location_Error exception - -- to be raised in task accept body, - -- propogated to a task block, and - -- handled there. Corresponding - -- exception propagated here also. - Report.Failed ("Expected exception not raised"); - exception - when Submarine_Tracking.Location_Error => - TC_LEB_Error := True; - when others => - Report.Failed ("Exception handled unexpectedly in " & - "Location_Error_Block"); - end Location_Error_Block; - - - Incorrect_Data_Block: - begin - Sonar_Contact := 200; - Trident.Contact (Sonar_Contact); -- Cause Incorrect_Data exception - -- to be raised in task accept body, - -- propogated to calling procedure. - Report.Failed ("Expected exception not raised"); - exception - when Submarine_Tracking.Incorrect_Data => - Submarine_Tracking.TC_Handled_In_Caller := True; - when others => - Report.Failed ("Exception handled unexpectedly in " & - "Incorrect_Data_Block"); - end Incorrect_Data_Block; - - - if TC_Main_Handler_Used or - not (Submarine_Tracking.TC_Handled_In_Caller and -- Check to see that - Submarine_Tracking.TC_Handled_In_Task_Block and -- all exceptions - Submarine_Tracking.TC_Handled_In_Accept and -- were handled in - Submarine_Tracking.TC_Reraised_In_Accept and -- proper locations. - TC_LEB_Error) - then - Report.Failed ("Exceptions handled in incorrect locations"); - end if; - - if Integer(Submarine_Tracking.Current_Position) /= 0 then - Report.Failed ("Variable incorrectly written in task processing"); - end if; - - delay ImpDef.Minimum_Task_Switch; - if Trident'Callable then - Report.Failed ("Task didn't terminate with exception propagation"); - end if; - - Report.Result; - -end CB20001; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20003.a b/gcc/testsuite/ada/acats/tests/cb/cb20003.a deleted file mode 100644 index daaf9ffe5c5..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb20003.a +++ /dev/null @@ -1,286 +0,0 @@ --- CB20003.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 exceptions can be raised, reraised, and handled in an --- accessed subprogram. --- --- --- TEST DESCRIPTION: --- Declare a record type, with one component being an access to --- subprogram type. Various subprograms are defined to fit the profile --- of this access type, such that the record component can refer to --- any of the subprograms. --- --- Each of the subprograms raises a different exception, based on the --- value of an input parameter. Exceptions are 1) raised, handled with --- an others handler, reraised and propagated to main to be handled in --- a specific handler; 2) raised, handled in a specific handler, reraised --- and propagated to the main to be handled in an others handler there, --- and 3) raised and propagated directly to the caller by the subprogram. --- --- Boolean variables are set throughout the test to ensure that correct --- exception processing has occurred, and these variables are verified at --- the conclusion of the test. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CB20003_0 is -- package Push_Buttons - - - Non_Default_Priority, - Non_Alert_Priority, - Non_Emergency_Priority : exception; - - Handled_With_Others, - Reraised_In_Subprogram, - Handled_In_Caller : Boolean := False; - - subtype Priority_Type is Integer range 1 .. 10; - - Default_Priority : Priority_Type := 1; - Alert_Priority : Priority_Type := 3; - Emergency_Priority : Priority_Type := 5; - - - type Button is tagged private; -- Private tagged type. - - type Button_Response_Ptr is access procedure (P : in Priority_Type; - B : in out Button); - - - -- Procedures accessible with Button_Response_Ptr type. - - procedure Default_Response (P : in Priority_Type; - B : in out Button); - - procedure Alert_Response (P : in Priority_Type; - B : in out Button); - - procedure Emergency_Response (P : in Priority_Type; - B : in out Button); - - - - procedure Push (B : in out Button; - P : in Priority_Type); - - procedure Set_Response (B : in out Button; - R : in Button_Response_Ptr); - -private - - type Button is tagged - record - Priority : Priority_Type := Default_Priority; - Response : Button_Response_Ptr := Default_Response'Access; - end record; - - -end CB20003_0; -- package Push_Buttons - - - --=================================================================-- - - -with Report; - -package body CB20003_0 is -- package Push_Buttons - - - procedure Push (B : in out Button; - P : in Priority_Type) is - begin -- Invoking subprogram designated - B.Response (P, B); -- by access value. - end Push; - - - procedure Set_Response (B : in out Button; - R : in Button_Response_Ptr) is - begin - B.Response := R; -- Set procedure value in record - end Set_Response; - - - procedure Default_Response (P : in Priority_Type; - B : in out Button) is - begin - if (P > Default_Priority) then - raise Non_Default_Priority; - Report.Failed ("Exception not raised in procedure body"); - else - B.Priority := P; - end if; - exception - when others => -- Catch exception with others handler - Handled_With_Others := True; -- Successfully caught with "others" - raise; - Report.Failed ("Exception not reraised in handler"); - end Default_Response; - - - - procedure Alert_Response (P : in Priority_Type; - B : in out Button) is - begin - if (P > Alert_Priority) then - raise Non_Alert_Priority; - Report.Failed ("Exception not raised in procedure body"); - else - B.Priority := P; - end if; - exception - when Non_Alert_Priority => - Reraised_In_Subprogram := True; - raise; -- Propagate to caller. - Report.Failed ("Exception not reraised in procedure excpt handler"); - when others => - Report.Failed ("Incorrect exception raised/handled"); - end Alert_Response; - - - - procedure Emergency_Response (P : in Priority_type; - B : in out Button) is - begin - if (P > Emergency_Priority) then - raise Non_Emergency_Priority; - Report.Failed ("Exception not raised in procedure body"); - else - B.Priority := P; - end if; - -- No exception handler here, exception will be propagated to caller. - end Emergency_Response; - - -end CB20003_0; -- package Push_Buttons - - - --=================================================================-- - - -with Report; -with CB20003_0; -- package Push_Buttons - -procedure CB20003 is - - package Push_Buttons renames CB20003_0; - - Console_Button : Push_Buttons.Button; - -begin - - Report.Test ("CB20003", "Check that exceptions can be raised, " & - "reraised, and handled in a subprogram " & - "referenced by an access to subprogram value"); - - - Default_Response_Processing: -- The exception - -- Handled_With_Others is to - -- be caught with an others - -- handler in Default_Resp., - -- reraised, and handled with - -- a specific handler here. - begin - - Push_Buttons.Push (Console_Button, -- Raise exception that will - Report.Ident_Int(2)); -- be handled in procedure. - exception - when Push_Buttons.Non_Default_Priority => - if not Push_Buttons.Handled_With_Others then -- Not reraised in - -- procedure. - Report.Failed - ("Exception not handled/reraised in procedure"); - end if; - when others => - Report.Failed ("Exception handled in " & - " Default_Response_Processing block"); - end Default_Response_Processing; - - - - Alert_Response_Processing: - begin - - Push_Buttons.Set_Response (Console_Button, - Push_Buttons.Alert_Response'access); - - Push_Buttons.Push (Console_Button, -- Raise exception that will - Report.Ident_Int(4)); -- be handled in procedure, - -- reraised, and propagated - -- to caller. - Report.Failed ("Exception not propagated to caller " & - "in Alert_Response_Processing block"); - - exception - when Push_Buttons.Non_Alert_Priority => - if not Push_Buttons.Reraised_In_Subprogram then -- Not reraised in - -- procedure. - Report.Failed ("Exception not reraised in procedure"); - end if; - when others => - Report.Failed ("Exception handled in " & - " Alert_Response_Processing block"); - end Alert_Response_Processing; - - - - Emergency_Response_Processing: - begin - - Push_Buttons.Set_Response (Console_Button, - Push_Buttons.Emergency_Response'access); - - Push_Buttons.Push (Console_Button, -- Raise exception that will - Report.Ident_Int(6)); -- be propagated directly to - -- caller. - Report.Failed ("Exception not propagated to caller " & - "in Emergency_Response_Processing block"); - - exception - when Push_Buttons.Non_Emergency_Priority => - Push_Buttons.Handled_In_Caller := True; - when others => - Report.Failed ("Exception handled in " & - " Emergency_Response_Processing block"); - end Emergency_Response_Processing; - - - - if not (Push_Buttons.Handled_With_Others and - Push_Buttons.Reraised_In_Subprogram and - Push_Buttons.Handled_In_Caller ) - then - Report.Failed ("Incorrect exception handling in referenced subprograms"); - end if; - - - Report.Result; - -end CB20003; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20004.a b/gcc/testsuite/ada/acats/tests/cb/cb20004.a deleted file mode 100644 index 42c0d767254..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb20004.a +++ /dev/null @@ -1,203 +0,0 @@ --- CB20004.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 exceptions propagate correctly from objects of --- protected types. Check propagation from protected entry bodies. --- --- TEST DESCRIPTION: --- Declare a package with a protected type, including entries and private --- data, simulating a bounded buffer abstraction. In the main procedure, --- perform entry calls on an object of the protected type that raises --- exceptions. --- Ensure that the exceptions are: --- 1) raised and handled locally in the entry body --- 2) raised in the entry body and handled/reraised to be handled --- by the caller. --- 3) raised in the entry body and propagated directly to the calling --- procedure. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CB20004_0 is -- Package Buffer. - - Max_Buffer_Size : constant := 2; - - Handled_In_Body, - Propagated_To_Caller, - Handled_In_Caller : Boolean := False; - - Data_Over_5, - Data_Degradation : exception; - - type Data_Item is range 0 .. 100; - - type Item_Array_Type is array (1 .. Max_Buffer_Size) of Data_Item; - - protected type Bounded_Buffer is - entry Put (Item : in Data_Item); - entry Get (Item : out Data_Item); - private - Item_Array : Item_Array_Type; - I, J : Integer range 1 .. Max_Buffer_Size := 1; - Count : Integer range 0 .. Max_Buffer_Size := 0; - end Bounded_Buffer; - -end CB20004_0; - - --=================================================================-- - -with Report; - -package body CB20004_0 is -- Package Buffer. - - protected body Bounded_Buffer is - - entry Put (Item : in Data_Item) when Count < Max_Buffer_Size is - begin - if Item > 10 then - Item_Array (I) := Item * 8; -- Constraint_Error will be raised - elsif Item > 5 then -- and handled in entry body. - raise Data_Over_5; -- Exception handled/reraised in - else -- entry body, propagated to caller. - Item_Array (I) := Item; -- Store data item in buffer. - I := (I mod Max_Buffer_Size) + 1; - Count := Count + 1; - end if; - exception - when Constraint_Error => - Handled_In_Body := True; - when Data_Over_5 => - Propagated_To_Caller := True; - raise; -- Propagate the exception to the caller. - end Put; - - - entry Get (Item : out Data_Item) when Count > 0 is - begin - Item := Item_Array(J); - J := (J mod Max_Buffer_Size) + 1; - Count := Count - 1; - if Count = 0 then - raise Data_Degradation; -- Exception to propagate to caller. - end if; - end Get; - - end Bounded_Buffer; - -end CB20004_0; - - - --=================================================================-- - - -with CB20004_0; -- Package Buffer. -with Report; - -procedure CB20004 is - - package Buffer renames CB20004_0; - - Data : Buffer.Data_Item := Buffer.Data_Item'First; - Data_Buffer : Buffer.Bounded_Buffer; -- an object of protected type. - - Handled_In_Caller : Boolean := False; -- same name as boolean declared - -- in package Buffer. -begin - - Report.Test ("CB20004", "Check that exceptions propagate correctly " & - "from objects of protected types" ); - - Initial_Data_Block: - begin -- Data causes Constraint_Error. - Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(51))); - - exception - when Constraint_Error => - Buffer.Handled_In_Body := False; -- Improper exception handling - -- in entry body. - Report.Failed ("Exception propagated to caller " & - " from Initial_Data_Block"); - when others => - Report.Failed ("Exception raised in processing and " & - "propagated to caller from Initial_Data_Block"); - end Initial_Data_Block; - - - Data_Entry_Block: - begin - -- Valid data. No exception. - Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(3))); - - -- Data will cause exception. - Data_Buffer.Put (7); -- Call protected object entry, - -- exception to be handled/ - -- reraised in entry body. - Report.Failed ("Data_Over_5 Exception not raised in processing"); - exception - when Buffer.Data_Over_5 => - if Buffer.Propagated_To_Caller then -- Reraised in entry body? - Buffer.Handled_In_Caller := True; - else - Report.Failed ("Exception not reraised in entry body"); - end if; - when others => - Report.Failed ("Exception raised in processing and propagated " & - "to caller from Data_Entry_Block"); - end Data_Entry_Block; - - - Data_Retrieval_Block: - begin - - Data_Buffer.Get (Data); -- Retrieval of buffer data, buffer now empty. - -- Exception will be raised in entry body, with - -- propagation to caller. - Report.Failed ("Data_Degradation Exception not raised in processing"); - exception - when Buffer.Data_Degradation => - Handled_In_Caller := True; -- Local Boolean used here. - when others => - Report.Failed ("Exception raised in processing and propagated " & - "to caller from Data_Retrieval_Block"); - end Data_Retrieval_Block; - - - if not (Buffer.Handled_In_Body and -- Validate proper exception - Buffer.Propagated_To_Caller and -- handling in entry bodies. - Buffer.Handled_In_Caller and - Handled_In_Caller) - then - Report.Failed ("Improper exception handling by entry bodies"); - end if; - - - Report.Result; - -end CB20004; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20005.a b/gcc/testsuite/ada/acats/tests/cb/cb20005.a deleted file mode 100644 index 898d2a2c644..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb20005.a +++ /dev/null @@ -1,210 +0,0 @@ --- CB20005.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 exceptions are raised and properly handled locally in --- protected operations. --- --- TEST DESCRIPTION: --- Declare a package with a protected type, including protected operation --- declarations and private data, simulating a counting semaphore. --- In the main procedure, perform calls on protected operations --- of the protected object designed to induce the raising of exceptions. --- --- Ensure that the exceptions are raised and handled locally in a --- protected procedures and functions, and that in this case the --- exceptions will not propagate to the calling unit. Use specific --- exception handlers in the protected functions. --- --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CB20005_0 is -- Package Semaphore. - - Handled_In_Function, - Handled_In_Procedure : Boolean := False; - - Resource_Overflow, - Resource_Underflow : exception; - - protected type Counting_Semaphore (Max_Resources : Integer) is - procedure Secure; - function Resource_Limit_Exceeded return Boolean; - procedure Release; - private - Count : Integer := Max_Resources; - end Counting_Semaphore; - -end CB20005_0; - - --=================================================================-- - -with Report; - -package body CB20005_0 is -- Package Semaphore. - - protected body Counting_Semaphore is - - procedure Secure is - begin - if (Count = 0) then -- No resources left to secure. - raise Resource_Underflow; - Report.Failed - ("Program control not transferred by raise in Secure"); - else - Count := Count - 1; -- Avail resources decremented. - end if; - exception - when Resource_Underflow => -- Exception handled locally in - Handled_In_Procedure := True; -- this protected operation. - when others => - Report.Failed ("Unexpected exception raised in Secure"); - end Secure; - - - function Resource_Limit_Exceeded return Boolean is - begin - if (Count > Max_Resources) then - raise Resource_Overflow; -- Exception used as control flow - -- mechanism. - Report.Failed - ("Program control not transferred by raise in " & - "Resource_Limit_Exceeded"); - else - return (False); - end if; - exception - when Resource_Overflow => -- Handle its own raised - Handled_In_Function := True; -- exception. - return (True); - when others => - Report.Failed - ("Unexpected exception raised in Resource_Limit_Exceeded"); - end Resource_Limit_Exceeded; - - - procedure Release is - begin - Count := Count + 1; -- Count of resources available - -- incremented. - if Resource_Limit_Exceeded then -- Call to protected operation - Count := Count - 1; -- function that raises/handles - end if; -- an exception. - exception - when Resource_Overflow => - Handled_In_Function := False; - Report.Failed ("Exception propagated to Function Release"); - when others => - Report.Failed ("Unexpected exception raised in Function Release"); - end Release; - - - end Counting_Semaphore; - -end CB20005_0; - - - --=================================================================-- - - -with CB20005_0; -- Package Semaphore. -with Report; - -procedure CB20005 is -begin - - Report.Test ("CB20005", "Check that exceptions are raised and handled " & - "correctly in protected operations" ); - - Test_Block: - declare - - package Semaphore renames CB20005_0; - - Total_Resources_Available : constant := 1; - - Resources : Semaphore.Counting_Semaphore(Total_Resources_Available); - -- An object of protected type. - - begin - - Allocate_Resources: - declare - Loop_Count : Integer := Total_Resources_Available + 1; - begin - for I in 1..Loop_Count loop -- Force exception. - Resources.Secure; - end loop; - exception - when Semaphore.Resource_Underflow => - Semaphore.Handled_In_Procedure := False; -- Excptn not handled - Report.Failed -- in prot. operation. - ("Resource_Underflow exception not handled " & - "in Allocate_Resources"); - when others => - Report.Failed - ("Exception unexpectedly raised during resource allocation"); - end Allocate_Resources; - - - Deallocate_Resources: - declare - Loop_Count : Integer := Total_Resources_Available + 1; - begin - for I in 1..Loop_Count loop -- Force excptn. - Resources.Release; - end loop; - exception - when Semaphore.Resource_Overflow => - Semaphore.Handled_In_Function := False; -- Exception not handled - Report.Failed -- in prot. operation. - ("Resource overflow not handled by function"); - when others => - Report.Failed - ("Exception raised during resource deallocation"); - end Deallocate_Resources; - - - if not (Semaphore.Handled_In_Procedure and -- Incorrect excpt. handling - Semaphore.Handled_In_Function) -- in protected operations. - then - Report.Failed - ("Improper exception handling by protected operations"); - end if; - - - exception - when others => - Report.Failed ("Exception raised and propagated in test"); - - end Test_Block; - - Report.Result; - -end CB20005; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20006.a b/gcc/testsuite/ada/acats/tests/cb/cb20006.a deleted file mode 100644 index f2b3c70a911..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb20006.a +++ /dev/null @@ -1,217 +0,0 @@ --- CB20006.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 exceptions are raised and properly handled (including --- propagation by reraise) in protected operations. --- --- TEST DESCRIPTION: --- Declare a package with a protected type, including protected operation --- declarations and private data, simulating a counting semaphore. --- In the main procedure, perform calls on protected operations --- of the protected object designed to induce the raising of exceptions. --- --- The exceptions raised are to be initially handled in the protected --- operations, but this handling involves the reraise of the exception --- and the propagation of the exception to the caller. --- --- Ensure that the exceptions are raised, handled / reraised successfully --- in protected procedures and functions. Use "others" handlers in the --- protected operations. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CB20006_0 is -- Package Semaphore. - - Reraised_In_Function, - Reraised_In_Procedure, - Handled_In_Function_Caller, - Handled_In_Procedure_Caller : Boolean := False; - - Resource_Overflow, - Resource_Underflow : exception; - - protected type Counting_Semaphore (Max_Resources : Integer) is - procedure Secure; - function Resource_Limit_Exceeded return Boolean; - procedure Release; - private - Count : Integer := Max_Resources; - end Counting_Semaphore; - -end CB20006_0; - - --=================================================================-- - -with Report; - -package body CB20006_0 is -- Package Semaphore. - - protected body Counting_Semaphore is - - procedure Secure is - begin - if (Count = 0) then -- No resources left to secure. - raise Resource_Underflow; - Report.Failed - ("Program control not transferred by raise in Procedure Secure"); - else - Count := Count - 1; -- Available resources decremented. - end if; - exception - when Resource_Underflow => - Reraised_In_Procedure := True; - raise; -- Exception propagated to caller. - Report.Failed ("Exception not propagated to caller from Secure"); - when others => - Report.Failed ("Unexpected exception raised in Secure"); - end Secure; - - - function Resource_Limit_Exceeded return Boolean is - begin - if (Count > Max_Resources) then - raise Resource_Overflow; -- Exception used as control flow - -- mechanism. - Report.Failed - ("Specific raise did not alter program control" & - " from Resource_Limit_Exceeded"); - else - return (False); - end if; - exception - when others => - Reraised_In_Function := True; - raise; -- Exception propagated to caller. - Report.Failed ("Exception not propagated to caller" & - " from Resource_Limit_Exceeded"); - end Resource_Limit_Exceeded; - - - procedure Release is - begin - Count := Count + 1; -- Count of resources available - -- incremented. - if Resource_Limit_Exceeded then -- Call to protected operation - Count := Count - 1; -- function that raises/reraises - -- an exception. - Report.Failed("Resource limit exceeded"); - end if; - - exception - when others => - raise; -- Reraised and propagated again. - Report.Failed ("Exception not reraised by procedure Release"); - end Release; - - - end Counting_Semaphore; - -end CB20006_0; - - - --=================================================================-- - - -with CB20006_0; -- Package Semaphore. -with Report; - -procedure CB20006 is -begin - - Report.Test ("CB20006", "Check that exceptions are raised and " & - "handled / reraised and propagated " & - "correctly by protected operations" ); - - Test_Block: - declare - - package Semaphore renames CB20006_0; - - Total_Resources_Available : constant := 1; - - Resources : Semaphore.Counting_Semaphore (Total_Resources_Available); - -- An object of protected type. - - begin - - Allocate_Resources: - declare - Loop_Count : Integer := Total_Resources_Available + 1; - begin - for I in 1..Loop_Count loop -- Force exception - Resources.Secure; - end loop; - Report.Failed - ("Exception not propagated from protected operation Secure"); - exception - when Semaphore.Resource_Underflow => -- Exception propagated - Semaphore.Handled_In_Procedure_Caller := True; -- from protected - when others => -- procedure. - Semaphore.Handled_In_Procedure_Caller := False; - end Allocate_Resources; - - - Deallocate_Resources: - declare - Loop_Count : Integer := Total_Resources_Available + 1; - begin - for I in 1..Loop_Count loop -- Force exception - Resources.Release; - end loop; - Report.Failed - ("Exception not propagated from protected operation Release"); - exception - when Semaphore.Resource_Overflow => -- Exception propagated - Semaphore.Handled_In_Function_Caller := True; -- from protected - when others => -- function. - Semaphore.Handled_In_Function_Caller := False; - end Deallocate_Resources; - - - if not (Semaphore.Reraised_In_Procedure and - Semaphore.Reraised_In_Function and - Semaphore.Handled_In_Procedure_Caller and - Semaphore.Handled_In_Function_Caller) - then -- Incorrect excpt. handling - Report.Failed -- in protected operations. - ("Improper exception handling/reraising by protected operations"); - end if; - - exception - - when others => - Report.Failed ("Unexpected exception " & - " raised and propagated in test"); - end Test_Block; - - Report.Result; - - -end CB20006; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20007.a b/gcc/testsuite/ada/acats/tests/cb/cb20007.a deleted file mode 100644 index 6d052517e3b..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb20007.a +++ /dev/null @@ -1,196 +0,0 @@ --- CB20007.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 exceptions are raised and can be directly propagated to --- the calling unit by protected operations. --- --- TEST DESCRIPTION: --- Declare a package with a protected type, including protected operation --- declarations and private data, simulating a counting semaphore. --- In the main procedure, perform calls on protected operations --- of the protected object designed to induce the raising of exceptions. --- --- The exceptions raised are to be propagated directly from the protected --- operations to the calling unit. --- --- Ensure that the exceptions are raised and correctly propagated directly --- to the calling unit from protected procedures and functions. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package CB20007_0 is -- Package Semaphore. - - Handled_In_Function_Caller, - Handled_In_Procedure_Caller : Boolean := False; - - Resource_Overflow, - Resource_Underflow : exception; - - protected type Counting_Semaphore (Max_Resources : Integer) is - procedure Secure; - function Resource_Limit_Exceeded return Boolean; - procedure Release; - private - Count : Integer := Max_Resources; - end Counting_Semaphore; - -end CB20007_0; - - --=================================================================-- - -with Report; - -package body CB20007_0 is -- Package Semaphore. - - protected body Counting_Semaphore is - - procedure Secure is - begin - if (Count = 0) then -- No resources left to secure. - raise Resource_Underflow; - Report.Failed ("Program control not transferred by raise"); - else - Count := Count - 1; -- Available resources decremented. - end if; - -- No exception handlers here, direct propagation to calling unit. - end Secure; - - - function Resource_Limit_Exceeded return Boolean is - begin - if (Count > Max_Resources) then - raise Resource_Overflow; -- Exception used as control flow - -- mechanism. - Report.Failed ("Program control not transferred by raise"); - else - return (False); - end if; - -- No exception handlers here, direct propagation to calling unit. - end Resource_Limit_Exceeded; - - - procedure Release is - begin - Count := Count + 1; -- Count of resources available - -- incremented. - if Resource_Limit_Exceeded then -- Call to protected operation - Count := Count - 1; -- function that raises an - -- exception. - Report.Failed("Resource limit exceeded"); - end if; - -- No exception handler here for exception raised in function. - -- Exception will propagate directly to calling unit. - end Release; - - - end Counting_Semaphore; - -end CB20007_0; - - - --=================================================================-- - - -with CB20007_0; -- Package Semaphore. -with Report; - -procedure CB20007 is -begin - - Test_Block: - declare - - package Semaphore renames CB20007_0; - - Total_Resources_Available : constant := 1; - - Resources : Semaphore.Counting_Semaphore (Total_Resources_Available); - -- An object of protected type. - - begin - - Report.Test ("CB20007", "Check that exceptions are raised and can " & - "be directly propagated to the calling unit " & - "by protected operations" ); - - Allocate_Resources: - declare - Loop_Count : Integer := Total_Resources_Available + 1; - begin -- Force exception. - for I in 1..Loop_Count loop - Resources.Secure; - end loop; - Report.Failed ("Exception not propagated from protected " & - " operation in Allocate_Resources"); - exception - when Semaphore.Resource_Underflow => -- Exception prop. - Semaphore.Handled_In_Procedure_Caller := True; -- from protected - -- procedure. - when others => - Report.Failed ("Unknown exception during resource allocation"); - end Allocate_Resources; - - - Deallocate_Resources: - declare - Loop_Count : Integer := Total_Resources_Available + 1; - begin -- Force exception. - for I in 1..Loop_Count loop - Resources.Release; - end loop; - Report.Failed ("Exception not propagated from protected " & - "operation in Deallocate_Resources"); - exception - when Semaphore.Resource_Overflow => -- Exception prop - Semaphore.Handled_In_Function_Caller := True; -- from protected - -- function. - when others => - Report.Failed ("Exception raised during resource deallocation"); - end Deallocate_Resources; - - - if not (Semaphore.Handled_In_Procedure_Caller and -- Incorrect exception - Semaphore.Handled_In_Function_Caller) -- handling in - then -- protected ops. - Report.Failed - ("Improper exception propagation by protected operations"); - end if; - - exception - - when others => - Report.Failed ("Unexpected exception " & - " raised and propagated in test"); - end Test_Block; - - - Report.Result; - -end CB20007; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20a02.a b/gcc/testsuite/ada/acats/tests/cb/cb20a02.a deleted file mode 100644 index 4c8537086cf..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb20a02.a +++ /dev/null @@ -1,155 +0,0 @@ --- CB20A02.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 the name and pertinent information about a user defined --- exception are available to an enclosing program unit even when the --- enclosing unit has no visibility into the scope where the exception --- is declared and raised. --- --- TEST DESCRIPTION: --- Declare a subprogram nested within the test subprogram. The enclosing --- subprogram does not have visibility into the nested subprogram. --- Declare and raise an exception in the nested subprogram, and allow --- the exception to propagate to the enclosing scope. Use the function --- Exception_Name in the enclosing subprogram to produce exception --- specific information when the exception is handled in an others --- handler. --- --- TEST FILES: --- --- This test depends on the following foundation code file: --- FB20A00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with FB20A00; -- Package containing Function Find -with Ada.Exceptions; -with Report; - -procedure CB20A02 is - - Seed_Number : Integer; - Random_Number : Integer := 0; - - --=================================================================-- - - function Random_Number_Generator (Seed : Integer) return Integer is - - Result : Integer := 0; - - HighSeedError, - Mid_Seed_Error, - L_o_w_S_e_e_d_E_r_r_o_r : exception; - - begin -- Random_Number_Generator - - - if (Report.Ident_Int (Seed) > 1000) then - raise HighSeedError; - elsif (Report.Ident_Int (Seed) > 100) then - raise Mid_Seed_Error; - elsif (Report.Ident_Int (Seed) > 10) then - raise L_o_w_S_e_e_d_E_r_r_o_r; - else - Seed_Number := ((Seed_Number * 417) + 231) mod 53; - Result := Seed_Number / 52; - end if; - - return Result; - - end Random_Number_Generator; - - --=================================================================-- - -begin - - Report.Test ("CB20A02", "Check that the name " & - "of a user defined exception is available " & - "to an enclosing program unit even when the " & - "enclosing unit has no visibility into the " & - "scope where the exception is declared and " & - "raised" ); - - High_Seed: - begin - -- This seed value will result in the raising of a HighSeedError - -- exception. - Seed_Number := 1001; - Random_Number := Random_Number_Generator (Seed_Number); - Report.Failed ("Exception not raised in High_Seed block"); - exception - when Error : others => - if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), - "HighSeedError") - then - Report.Failed ("Expected HighSeedError, but found " & - Ada.Exceptions.Exception_Name (Error)); - end if; - end High_Seed; - - - Mid_Seed: - begin - -- This seed value will generate a Mid_Seed_Error exception. - Seed_Number := 101; - Random_Number := Random_Number_Generator (Seed_Number); - Report.Failed ("Exception not raised in Mid_Seed block"); - exception - when Error : others => - if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), - "Mid_Seed_Error") - then - Report.Failed ("Expected Mid_Seed_Error, but found " & - Ada.Exceptions.Exception_Name (Error)); - end if; - end Mid_Seed; - - - Low_Seed: - begin - -- This seed value will result in the raising of a - -- L_o_w_S_e_e_d_E_r_r_o_r exception. - Seed_Number := 11; - Random_Number := Random_Number_Generator (Seed_Number); - Report.Failed ("Exception not raised in Low_Seed block"); - exception - when Error : others => - if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), - "L_o_w_S_e_e_d_E_r_r_o_r") - then - Report.Failed ("Expected L_o_w_S_e_e_d_E_r_r_o_r but found " & - Ada.Exceptions.Exception_Name (Error)); - end if; - end Low_Seed; - - - Report.Result; - -end CB20A02; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40005.a b/gcc/testsuite/ada/acats/tests/cb/cb40005.a deleted file mode 100644 index 681ec18ff28..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb40005.a +++ /dev/null @@ -1,339 +0,0 @@ --- CB40005.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 exceptions raised in non-generic code can be handled by --- a procedure in a generic package. Check that the exception identity --- can be properly retrieved from the generic code and used by the --- non-generic code. --- --- TEST DESCRIPTION: --- This test models a possible usage paradigm for the type: --- Ada.Exceptions.Exception_Occurrence. --- --- A generic package takes access to procedure types (allowing it to --- be used at any accessibility level) and defines a "fail soft" --- procedure that takes designators to a procedure to call, a --- procedure to call in the event that it fails, and a function to --- call to determine the next action. --- --- In the event an exception occurs on the call to the first procedure, --- the exception is stored in a stack; along with the designator to the --- procedure that caused it; allowing the procedure to be called again, --- or the exception to be re-raised. --- --- A full implementation of such a tool would use a more robust storage --- mechanism, and would provide a more flexible interface. --- --- --- CHANGE HISTORY: --- 29 MAR 96 SAIC Initial version --- 12 NOV 96 SAIC Revised for 2.1 release --- ---! - ------------------------------------------------------------------ CB40005_0 - -with Ada.Exceptions; -generic - type Proc_Pointer is access procedure; - type Func_Pointer is access function return Proc_Pointer; -package CB40005_0 is -- Fail_Soft - - - procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer; - Proc_To_Call_On_Exception : Proc_Pointer := null; - Retry_Routine : Func_Pointer := null ); - - function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence; - - function Top_Event_Procedure return Proc_Pointer; - - procedure Pop_Event; - - function Event_Stack_Size return Natural; - -end CB40005_0; -- Fail_Soft - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CB40005_0 - -with Report; -package body CB40005_0 is - - type History_Event is record - Exception_Event : Ada.Exceptions.Exception_Occurrence_Access; - Procedure_Called : Proc_Pointer; - end record; - - procedure Store_Event( Proc_Called : Proc_Pointer; - Error : Ada.Exceptions.Exception_Occurrence ); - - procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer; - Proc_To_Call_On_Exception : Proc_Pointer := null; - Retry_Routine : Func_Pointer := null ) is - - Current_Proc_To_Call : Proc_Pointer := Proc_To_Call; - - begin - while Current_Proc_To_Call /= null loop - begin - Current_Proc_To_Call.all; -- call procedure through pointer - Current_Proc_To_Call := null; - exception - when Capture: others => - Store_Event( Current_Proc_To_Call, Capture ); - if Proc_To_Call_On_Exception /= null then - Proc_To_Call_On_Exception.all; - end if; - if Retry_Routine /= null then - Current_Proc_To_Call := Retry_Routine.all; - else - Current_Proc_To_Call := null; - end if; - end; - end loop; - end Fail_Soft_Call; - - Stack : array(1..10) of History_Event; -- minimal, sufficient for testing - - Stack_Top : Natural := 0; - - procedure Store_Event( Proc_Called : Proc_Pointer; - Error : Ada.Exceptions.Exception_Occurrence ) - is - begin - Stack_Top := Stack_Top +1; - Stack(Stack_Top) := ( Ada.Exceptions.Save_Occurrence(Error), - Proc_Called ); - end Store_Event; - - function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence is - begin - if Stack_Top > 0 then - return Stack(Stack_Top).Exception_Event.all; - else - return Ada.Exceptions.Null_Occurrence; - end if; - end Top_Event_Exception; - - function Top_Event_Procedure return Proc_Pointer is - begin - if Stack_Top > 0 then - return Stack(Stack_Top).Procedure_Called; - else - return null; - end if; - end Top_Event_Procedure; - - procedure Pop_Event is - begin - if Stack_Top > 0 then - Stack_Top := Stack_Top -1; - else - Report.Failed("Stack Error"); - end if; - end Pop_Event; - - function Event_Stack_Size return Natural is - begin - return Stack_Top; - end Event_Stack_Size; - -end CB40005_0; - -------------------------------------------------------------------- CB40005 - -with Report; -with TCTouch; -with CB40005_0; -with Ada.Exceptions; -procedure CB40005 is - - type Proc_Pointer is access procedure; - type Func_Pointer is access function return Proc_Pointer; - - package Fail_Soft is new CB40005_0(Proc_Pointer, Func_Pointer); - - procedure Cause_Standard_Exception; - - procedure Cause_Visible_Exception; - - procedure Cause_Invisible_Exception; - - Exception_Procedure_Pointer : Proc_Pointer; - - Visible_Exception : exception; - - procedure Action_On_Exception; - - function Retry_Procedure return Proc_Pointer; - - Raise_Error : Boolean; - - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - procedure Cause_Standard_Exception is - begin - TCTouch.Touch('S'); --------------------------------------------------- S - if Raise_Error then - raise Constraint_Error; - end if; - end Cause_Standard_Exception; - - procedure Cause_Visible_Exception is - begin - TCTouch.Touch('V'); --------------------------------------------------- V - if Raise_Error then - raise Visible_Exception; - end if; - end Cause_Visible_Exception; - - procedure Cause_Invisible_Exception is - Invisible_Exception : exception; - begin - TCTouch.Touch('I'); --------------------------------------------------- I - if Raise_Error then - raise Invisible_Exception; - end if; - end Cause_Invisible_Exception; - - procedure Action_On_Exception is - begin - TCTouch.Touch('A'); --------------------------------------------------- A - end Action_On_Exception; - - function Retry_Procedure return Proc_Pointer is - begin - TCTouch.Touch('R'); --------------------------------------------------- R - return Action_On_Exception'Access; - end Retry_Procedure; - - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -begin -- Main test procedure. - - Report.Test ("CB40005", "Check that exceptions raised in non-generic " & - "code can be handled by a procedure in a generic " & - "package. Check that the exception identity can " & - "be properly retrieved from the generic code and " & - "used by the non-generic code" ); - - -- first, check that the no exception cases cause no action on the stack - Raise_Error := False; - - Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S - - Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V - Action_On_Exception'Access, - Retry_Procedure'Access ); - - Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I - null, - Retry_Procedure'Access ); - - TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Empty stack"); - - TCTouch.Validate( "SVI", "Non error case check" ); - - -- second, check that error cases add to the stack - Raise_Error := True; - - Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S - - Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V - Action_On_Exception'Access, -- A - Retry_Procedure'Access ); -- RA - - Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I - null, - Retry_Procedure'Access ); -- RA - - TCTouch.Assert( Fail_Soft.Event_Stack_Size = 3, "Stack = 3"); - - TCTouch.Validate( "SVARAIRA", "Error case check" ); - - -- check that the exceptions and procedure were stored correctly - -- on the stack - Raise_Error := False; - - -- return procedure pointer from top of stack and call the procedure - -- through that pointer: - - Fail_Soft.Top_Event_Procedure.all; - - TCTouch.Validate( "I", "Invisible case unwind" ); - - begin - Ada.Exceptions.Raise_Exception( - Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); - Report.Failed("1: Exception not raised"); - exception - when Constraint_Error => Report.Failed("1: Raised Constraint_Error"); - when Visible_Exception => Report.Failed("1: Raised Visible_Exception"); - when others => null; -- expected case - end; - - Fail_Soft.Pop_Event; - - -- return procedure pointer from top of stack and call the procedure - -- through that pointer: - - Fail_Soft.Top_Event_Procedure.all; - - TCTouch.Validate( "V", "Visible case unwind" ); - - begin - Ada.Exceptions.Raise_Exception( - Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); - Report.Failed("2: Exception not raised"); - exception - when Constraint_Error => Report.Failed("2: Raised Constraint_Error"); - when Visible_Exception => null; -- expected case - when others => Report.Failed("2: Raised Invisible_Exception"); - end; - - Fail_Soft.Pop_Event; - - Fail_Soft.Top_Event_Procedure.all; - - TCTouch.Validate( "S", "Standard case unwind" ); - - begin - Ada.Exceptions.Raise_Exception( - Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); - Report.Failed("3: Exception not raised"); - exception - when Constraint_Error => null; -- expected case - when Visible_Exception => Report.Failed("3: Raised Visible_Exception"); - when others => Report.Failed("3: Raised Invisible_Exception"); - end; - - Fail_Soft.Pop_Event; - - TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Stack empty after pops"); - - Report.Result; - -end CB40005; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a01.a b/gcc/testsuite/ada/acats/tests/cb/cb40a01.a deleted file mode 100644 index 1c569119afb..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb40a01.a +++ /dev/null @@ -1,135 +0,0 @@ --- CB40A01.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 a user defined exception is correctly propagated out of --- a public child package. --- --- TEST DESCRIPTION: --- Declare a public child package containing a procedure used to --- analyze the alphanumeric content of a particular text string. --- The procedure contains a processing loop that continues until the --- range of the text string is exceeded, at which time a user defined --- exception is raised. This exception propagates out of the procedure --- through the parent package, to the main test program. --- --- Exception Type Raised: --- * User Defined --- Predefined --- --- Hierarchical Structure Employed For This Test: --- * Parent Package --- * Public Child Package --- Private Child Package --- Public Child Subprogram --- Private Child Subprogram --- --- TEST FILES: --- This test depends on the following foundation code: --- FB40A00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - - -package FB40A00.CB40A01_0 is -- package Text_Parser.Processing - - procedure Process_Text (Text : in String_Pointer_Type); - -end FB40A00.CB40A01_0; - - - --=================================================================-- - - -with Report; - -package body FB40A00.CB40A01_0 is - - procedure Process_Text (Text : in String_Pointer_Type) is - Pos : Natural := Text'First - 1; - begin - loop -- Process string, raise exception upon completion. - Pos := Pos + 1; - if Pos > Text.all'Last then - raise Completed_Text_Processing; - elsif (Text.all (Pos) in 'A' .. 'Z') or - (Text.all (Pos) in 'a' .. 'z') or - (Text.all (Pos) in '0' .. '9') then - Increment_AlphaNumeric_Count; - else - Increment_Non_AlphaNumeric_Count; - end if; - end loop; - -- No exception handler here, exception propagates. - Report.Failed ("No exception raised in child package subprogram"); - end Process_Text; - -end FB40A00.CB40A01_0; - - - --=================================================================-- - - -with FB40A00.CB40A01_0; -with Report; - -procedure CB40A01 is - - String_Pointer : FB40A00.String_Pointer_Type := - new String'("'Twas the night before Christmas, " & - "and all through the house..."); - -begin - - Process_Block: - begin - - Report.Test ("CB40A01", "Check that a user defined exception " & - "is correctly propagated out of a " & - "public child package"); - - FB40A00.CB40A01_0.Process_Text (String_Pointer); - - Report.Failed ("Exception should have been handled"); - - exception - - when FB40A00.Completed_Text_Processing => -- Correct exception - if FB40A00.AlphaNumeric_Count /= 48 then -- propagation. - Report.Failed ("Incorrect string processing"); - end if; - - when others => - Report.Failed ("Exception handled in an others handler"); - - end Process_Block; - - Report.Result; - -end CB40A01; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a020.a b/gcc/testsuite/ada/acats/tests/cb/cb40a020.a deleted file mode 100644 index 09830b87f5a..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb40a020.a +++ /dev/null @@ -1,95 +0,0 @@ --- CB40A020.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: --- See CB40A021.AM. --- --- TEST DESCRIPTION: --- See CB40A021.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- FB40A00.A --- => CB40A020.A --- CB40A021.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. --- ---! - - -package FB40A00.CB40A020_0 is -- package Text_Parser.Processing - - function Count_AlphaNumerics (Text : in String) return Natural; - -end FB40A00.CB40A020_0; - - - --=================================================================-- - - --- Text_Parser.Processing.Process_Text -with Report; -private procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String); - -procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String) is - Pos : Natural := Text'First - 1; -begin - loop -- Process string, raise exception upon completion. - Pos := Pos + 1; - if Pos > Text'Last then - raise Completed_Text_Processing; - elsif (Text (Pos) in 'A' .. 'Z') or - (Text (Pos) in 'a' .. 'z') or - (Text (Pos) in '0' .. '9') then - Increment_AlphaNumeric_Count; - else - Increment_Non_AlphaNumeric_Count; - end if; - end loop; - -- No exception handler here, exception propagates. - Report.Failed ("No exception raised in child package subprogram"); -end FB40A00.CB40A020_0.CB40A020_1; - - - --=================================================================-- - - -with FB40A00.CB40A020_0.CB40A020_1; -- "with" of private child subprogram - -- Text_Parser.Processing.Process_Text -package body FB40A00.CB40A020_0 is - - function Count_AlphaNumerics (Text : in String) return Natural is - begin - FB40A00.CB40A020_0.CB40A020_1 (Text); -- Call prvt child proc. - return (AlphaNumeric_Count); -- Global maintained in parent. - -- No exception handler here, exception propagates. - end Count_AlphaNumerics; - -end FB40A00.CB40A020_0; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a030.a b/gcc/testsuite/ada/acats/tests/cb/cb40a030.a deleted file mode 100644 index 8b053e2f0af..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb40a030.a +++ /dev/null @@ -1,105 +0,0 @@ --- CB40A030.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: --- See CB40A031.AM. --- --- TEST DESCRIPTION: --- See CB40A031.AM. --- --- TEST FILES: --- This test consists of the following files: --- --- FB40A00.A --- => CB40A030.A --- CB40A031.AM --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. --- ---! - - -package FB40A00.CB40A030_0 is -- package Text_Parser.Character_Counting - - function Count_AlphaNumerics (Text : in String) return Natural; - -end FB40A00.CB40A030_0; - - - --=================================================================-- - - -private package FB40A00.CB40A030_1 is -- package Text_Parser.Processing - - procedure Process_Text (Text : in String); - -end FB40A00.CB40A030_1; - - - --=================================================================-- - - -package body FB40A00.CB40A030_1 is - - procedure Process_Text (Text : in String) is - Loop_Count : Integer := Text'Length + 1; - begin - for Pos in 1..Loop_Count loop -- Process string, force the - -- raise of Constraint_Error. - if (Text (Pos) in 'a'..'z') or - (Text (Pos) in 'A'..'Z') or - (Text (Pos) in '0'..'9') then - Increment_AlphaNumeric_Count; - else - Increment_Non_AlphaNumeric_Count; - end if; - - end loop; - -- No exception handler here, exception propagates. - end Process_Text; - -end FB40A00.CB40A030_1; - - - --=================================================================-- - - -with FB40A00.CB40A030_1; -- private sibling package Text_Parser.Processing; - -package body FB40A00.CB40A030_0 is - - function Count_AlphaNumerics (Text : in String) return Natural is - begin - FB40A00.CB40A030_1.Process_Text (Text); -- Call proc in prvt child - -- package that is a - -- sibling of this package. - return (AlphaNumeric_Count); - -- No exception handler here, exception propagates. - end Count_AlphaNumerics; - -end FB40A00.CB40A030_0; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a04.a b/gcc/testsuite/ada/acats/tests/cb/cb40a04.a deleted file mode 100644 index 45209b9beab..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb40a04.a +++ /dev/null @@ -1,119 +0,0 @@ --- CB40A04.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 a predefined exception is correctly propagated out of a --- public child function to a client. --- --- TEST DESCRIPTION: --- Declare a public child subprogram. Define the processing loop --- inside the subprogram to expect a string with index starting at 1. --- From the test procedure, call the child subprogram with a slice --- from the middle of a string variable. This will cause an exception --- to be raised in the child and propagated to the caller. --- --- Exception Type Raised: --- User Defined --- * Predefined --- --- Hierarchical Structure Employed For This Test: --- * Parent Package --- Public Child Package --- Private Child Package --- * Public Child Subprogram --- Private Child Subprogram --- --- TEST FILES: --- This test depends on the following foundation code: --- FB40A00.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - - --- Child subprogram Text_Parser.Count_AlphaNumerics - -function FB40A00.CB40A04_0 (Text : string) return Natural is -begin - - for I in 1 .. Text'Last loop -- Raise immediate Constraint_Error - if (Text (I) in 'a'..'z') or -- with String slice passed from - (Text (I) in 'A'..'Z') or -- caller. (Slice'first /= 1) - (Text (I) in '0'..'9') then - Increment_AlphaNumeric_Count; - else - Increment_Non_AlphaNumeric_Count; - end if; - end loop; - - return (AlphaNumeric_Count); -- Global in parent package. - - -- No exception handler here, exception propagates. - -end FB40A00.CB40A04_0; - - - --=================================================================-- - - -with FB40A00.CB40A04_0; -- Explicit "with" of Text_Parser.Count_AlphaNumerics -with Report; -- Implicit "with" of Text_Parser. - -procedure CB40A04 is - - String_Var : String (1..19) := "The quick brown fox"; - - Number_Of_AlphaNumeric_Characters : Natural := 0; - -begin - - Report.Test ("CB40A04", "Check that a predefined exception is " & - "correctly propagated out of a public " & - "child function to a client"); - - Process_Block: - begin - - Number_Of_AlphaNumeric_Characters := -- Provide slice of string - FB40A00.CB40A04_0 (String_Var (5..10)); -- to subprogram. - - Report.Failed ("Exception should have been handled"); - - exception - - when Constraint_Error => -- Correct exception - null; -- propagation. - - when others => - Report.Failed ("Exception handled in an others handler"); - - end Process_Block; - - Report.Result; - -end CB40A04; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41001.a b/gcc/testsuite/ada/acats/tests/cb/cb41001.a deleted file mode 100644 index 95ad868feaf..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb41001.a +++ /dev/null @@ -1,213 +0,0 @@ --- CB41001.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 the 'Identity attribute returns the unique identity of an --- exception. Check that the Raise_Exception procedure can raise an --- exception that is specified through the use of the 'Identity attribute, --- and that Reraise_Occurrence can re-raise an exception occurrence --- using an exception choice parameter. --- --- TEST DESCRIPTION: --- This test uses the capability of the 'Identity attribute, which --- returns the unique identity of an exception, as an Exception_Id --- result. This result is used as an input parameter to the procedure --- Raise_Exception. The exception that results is handled, propagated --- using the Reraise_Occurrence procedure, and handled again. --- The above actions are performed for both a user-defined and a --- predefined exception. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 11 Nov 96 SAIC ACVC 2.1: Modified Propagate_User_Exception. --- ---! - -with Report; -with Ada.Exceptions; - -procedure CB41001 is - -begin - - Report.Test ("CB41001", "Check that the 'Identity attribute returns " & - "the unique identity of an exception. Check " & - "that the 'Identity attribute is of type " & - "Exception_Id. Check that the " & - "Raise_Exception procedure can raise an " & - "exception that is specified through the " & - "use of the 'Identity attribute"); - Test_Block: - declare - - Check_Points : constant := 5; - - type Check_Point_Array_Type is array (1..Check_Points) of Boolean; - - -- Global array used to track the processing path through the test. - TC_Check_Points : Check_Point_Array_Type := (others => False); - - A_User_Defined_Exception : Exception; - An_Exception_ID : Ada.Exceptions.Exception_Id := - Ada.Exceptions.Null_Id; - - procedure Propagate_User_Exception is - Hidden_Exception : Exception; - begin - -- Use the 'Identity function to store the unique identity of a - -- user defined exception into a variable of type Exception_Id. - - An_Exception_ID := A_User_Defined_Exception'Identity; - - -- Raise this user defined exception using the result of the - -- 'Identity attribute. - - Ada.Exceptions.Raise_Exception(E => An_Exception_Id); - - Report.Failed("User defined exception not raised by " & - "procedure Propagate_User_Exception"); - - exception - when Proc_Excpt : A_User_Defined_Exception => -- Expected exception. - begin - - -- By raising a different exception at this point, the - -- information associated with A_User_Defined_Exception must - -- be correctly stacked internally. - - Ada.Exceptions.Raise_Exception(Hidden_Exception'Identity); - Report.Failed("Hidden_Exception not raised by " & - "procedure Propagate_User_Exception"); - exception - when others => - TC_Check_Points(1) := True; - - -- Reraise the original exception, which will be propagated - -- outside the scope of this procedure. - - Ada.Exceptions.Reraise_Occurrence(Proc_Excpt); - Report.Failed("User defined exception not reraised"); - - end; - - when others => - Report.Failed("Unexpected exception raised by " & - "Procedure Propagate_User_Exception"); - end Propagate_User_Exception; - - begin - - User_Exception_Block: - begin - -- Call procedure to raise, handle, and reraise a user defined - -- exception. - Propagate_User_Exception; - - Report.Failed("User defined exception not propagated from " & - "procedure Propagate_User_Exception"); - - exception - when A_User_Defined_Exception => -- Expected exception. - TC_Check_Points(2) := True; - when others => - Report.Failed - ("Unexpected exception handled in User_Exception_Block"); - end User_Exception_Block; - - - Predefined_Exception_Block: - begin - - Inner_Block: - begin - - begin - -- Use the 'Identity attribute as an input parameter to the - -- Raise_Exception procedure. - - Ada.Exceptions.Raise_Exception(Constraint_Error'Identity); - Report.Failed("Constraint_Error not raised in Inner_Block"); - - exception - when Excpt : Constraint_Error => -- Expected exception. - TC_Check_Points(3) := True; - - -- Reraise the exception. - Ada.Exceptions.Reraise_Occurrence(X => Excpt); - Report.Failed("Predefined exception not raised from " & - "within the exception handler - 1"); - when others => - Report.Failed("Incorrect result from attempt to raise " & - "Constraint_Error using the 'Identity " & - "attribute - 1"); - end; - - Report.Failed("Constraint_Error not reraised in Inner_Block"); - - exception - when Block_Excpt : Constraint_Error => -- Expected exception. - TC_Check_Points(4) := True; - - -- Reraise the exception in a scope where the exception - -- was not originally raised. - - Ada.Exceptions.Reraise_Occurrence(X => Block_Excpt); - Report.Failed("Predefined exception not raised from " & - "within the exception handler - 2"); - - when others => - Report.Failed("Incorrect result from attempt to raise " & - "Constraint_Error using the 'Identity " & - "attribute - 2"); - end Inner_Block; - - Report.Failed("Exception not propagated from Inner_Block"); - - exception - when Constraint_Error => -- Expected exception. - TC_Check_Points(5) := True; - when others => - Report.Failed("Unexpected exception handled after second " & - "reraise of Constraint_Error"); - end Predefined_Exception_Block; - - - -- Verify the processing path taken through the test. - - for i in 1..Check_Points loop - if not TC_Check_Points(i) then - Report.Failed("Incorrect processing path taken through test, " & - "didn't pass check point #" & Integer'Image(i)); - end if; - end loop; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CB41001; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41002.a b/gcc/testsuite/ada/acats/tests/cb/cb41002.a deleted file mode 100644 index 1b3898154de..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb41002.a +++ /dev/null @@ -1,283 +0,0 @@ --- CB41002.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 the message string input parameter in a call to the --- Raise_Exception procedure is associated with the raised exception --- occurrence, and that the message string can be obtained using the --- Exception_Message function with the associated Exception_Occurrence --- object. Check that Function Exception_Information is available --- to provide implementation-defined information about the exception --- occurrence. --- --- TEST DESCRIPTION: --- This test checks that a message associated with a raised exception --- is propagated with the exception, and can be retrieved using the --- Exception_Message function. The exception will be raised using the --- 'Identity attribute as a parameter to the Raise_Exception procedure, --- and an associated message string will be provided. The exception --- will be handled, and the message associated with the occurrence will --- be compared to the original source message (non-default). --- --- The test also includes a simulated logging procedure --- (Check_Exception_Information) that checks that Exception_Information --- can be called. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 22 Jun 00 RLB Added a check at Exception_Information can be --- called. --- ---! - -with Report; -with Ada.Exceptions; - -procedure CB41002 is -begin - - Report.Test ("CB41002", "Check that the message string input parameter " & - "in a call to the Raise_Exception procedure is " & - "associated with the raised exception " & - "occurrence, and that the message string can " & - "be obtained using the Exception_Message " & - "function with the associated " & - "Exception_Occurrence object. Also check that " & - "the Exception_Information function can be called"); - - Test_Block: - declare - - Number_Of_Exceptions : constant := 3; - - User_Exception_1, - User_Exception_2, - User_Exception_3 : exception; - - type String_Ptr is access String; - - User_Messages : constant array (1..Number_Of_Exceptions) - of String_Ptr := - (new String'("Msg"), - new String'("This message will override the default " & - "message provided by the implementation"), - new String'("The message can be captured by procedure" & -- 200 chars - " Exception_Message. It is designed to b" & - "e exactly 200 characters in length, sinc" & - "e there is a permission concerning the " & - "truncation of a message over 200 chars. ")); - - procedure Check_Exception_Information ( - Occur : in Ada.Exceptions.Exception_Occurrence) is - -- Simulates an error logging routine. - Info : constant String := - Ada.Exceptions.Exception_Information (Occur); - function Is_Substring_of (Target, Search : in String) return Boolean is - -- Returns True if Search is a substring of Target, and False - -- otherwise. - begin - for I in Report.Ident_Int(Target'First) .. - Target'Last - Search'Length + 1 loop - if Target(I .. I+Search'Length-1) = Search then - return True; - end if; - end loop; - return False; - end Is_Substring_of; - begin - -- We can't display Info, as it often contains line breaks - -- (confusing Report), and might look much like the failure of a test - -- with an unhandled exception (thus confusing grading tools). - -- - -- We don't particular care if the implementation advice is followed, - -- but we make these checks to insure that a compiler cannot optimize - -- away Info or the rest of this routine. - if not Is_Substring_of (Info, - Ada.Exceptions.Exception_Name (Occur)) then - Report.Comment ("Exception_Information does not contain " & - "Exception_Name - see 11.4.1(19)"); - elsif not Is_Substring_of (Info, - Ada.Exceptions.Exception_Message (Occur)) then - Report.Comment ("Exception_Information does not contain " & - "Exception_Message - see 11.4.1(19)"); - end if; - end Check_Exception_Information; - - begin - - for i in 1..Number_Of_Exceptions loop - begin - - -- Raise a user-defined exception with a specific message string. - case i is - when 1 => - Ada.Exceptions.Raise_Exception(User_Exception_1'Identity, - User_Messages(i).all); - when 2 => - Ada.Exceptions.Raise_Exception(User_Exception_2'Identity, - User_Messages(i).all); - when 3 => - Ada.Exceptions.Raise_Exception(User_Exception_3'Identity, - User_Messages(i).all); - when others => - Report.Failed("Incorrect result from Case statement"); - end case; - - Report.Failed - ("Exception not raised by procedure Exception_With_Message " & - "for User_Exception #" & Integer'Image(i)); - - exception - when Excptn : others => - - begin - -- The message that is associated with the raising of each - -- exception is captured here using the Exception_Message - -- function. - - if User_Messages(i).all /= - Ada.Exceptions.Exception_Message(Excptn) - then - Report.Failed - ("Message captured from exception is not the " & - "message provided when the exception was raised, " & - "User_Exception #" & Integer'Image(i)); - end if; - - Check_Exception_Information(Excptn); - end; - end; - end loop; - - - - -- Verify that the exception specific message is carried across - -- various boundaries: - - begin - - begin - Ada.Exceptions.Raise_Exception(User_Exception_1'Identity, - User_Messages(1).all); - Report.Failed("User_Exception_1 not raised"); - end; - Report.Failed("User_Exception_1 not propagated"); - exception - when Excptn : User_Exception_1 => - - if User_Messages(1).all /= - Ada.Exceptions.Exception_Message(Excptn) - then - Report.Failed("User_Message_1 not found"); - end if; - Check_Exception_Information(Excptn); - - when others => Report.Failed("Unexpected exception handled - 1"); - end; - - - - begin - - begin - Ada.Exceptions.Raise_Exception(User_Exception_2'Identity, - User_Messages(2).all); - Report.Failed("User_Exception_2 not raised"); - exception - when Exc : User_Exception_2 => - - -- The exception is reraised here; message should propagate - -- with exception occurrence. - - Ada.Exceptions.Reraise_Occurrence(Exc); - when others => Report.Failed("User_Exception_2 not handled"); - end; - Report.Failed("User_Exception_2 not propagated"); - exception - when Excptn : User_Exception_2 => - - if User_Messages(2).all /= - Ada.Exceptions.Exception_Message(Excptn) - then - Report.Failed("User_Message_2 not found"); - end if; - Check_Exception_Information(Excptn); - - when others => Report.Failed("Unexpected exception handled - 2"); - end; - - - -- Check exception and message propagation across task boundaries. - - declare - - task Raise_An_Exception is -- single task - entry Raise_It; - end Raise_An_Exception; - - task body Raise_An_Exception is - begin - accept Raise_It do - Ada.Exceptions.Raise_Exception(User_Exception_3'Identity, - User_Messages(3).all); - end Raise_It; - Report.Failed("User_Exception_3 not raised"); - exception - when Excptn : User_Exception_3 => - if User_Messages(3).all /= - Ada.Exceptions.Exception_Message(Excptn) - then - Report.Failed - ("User_Message_3 not returned inside task body"); - end if; - Check_Exception_Information(Excptn); - when others => - Report.Failed("Incorrect exception raised in task body"); - end Raise_An_Exception; - - begin - Raise_An_Exception.Raise_It; -- Exception will be propagated here. - Report.Failed("User_Exception_3 not propagated to caller"); - exception - when Excptn : User_Exception_3 => - if User_Messages(3).all /= - Ada.Exceptions.Exception_Message(Excptn) - then - Report.Failed("User_Message_3 not returned to caller of task"); - end if; - Check_Exception_Information(Excptn); - when others => - Report.Failed("Incorrect exception raised by task"); - end; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CB41002; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41003.a b/gcc/testsuite/ada/acats/tests/cb/cb41003.a deleted file mode 100644 index aee0b094ce5..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb41003.a +++ /dev/null @@ -1,358 +0,0 @@ --- CB41003.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 an exception occurrence can be saved into an object of --- type Exception_Occurrence using the procedure Save_Occurrence. --- Check that a saved exception occurrence can be used to reraise --- another occurrence of the same exception using the procedure --- Reraise_Occurrence. Check that the function Save_Occurrence will --- allocate a new object of type Exception_Occurrence_Access, and saves --- the source exception to the new object which is returned as the --- function result. --- --- TEST DESCRIPTION: --- This test verifies that an occurrence of an exception can be saved, --- using either of two overloaded versions of Save_Occurrence. The --- procedure version of Save_Occurrence is used to save an occurrence --- of a user defined exception into an object of type --- Exception_Occurrence. This object is then used as an input --- parameter to procedure Reraise_Occurrence, the expected exception is --- handled, and the exception id of the handled exception is compared --- to the id of the originally raised exception. --- The function version of Save_Occurrence returns a result of --- Exception_Occurrence_Access, and is used to store the value of another --- occurrence of the user defined exception. The resulting access value --- is dereferenced and used as an input to Reraise_Occurrence. The --- resulting exception is handled, and the exception id of the handled --- exception is compared to the id of the originally raised exception. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Report; -with Ada.Exceptions; - -procedure CB41003 is - -begin - - Report.Test ("CB41003", "Check that an exception occurrence can " & - "be saved into an object of type " & - "Exception_Occurrence using the procedure " & - "Save_Occurrence"); - - Test_Block: - declare - - use Ada.Exceptions; - - User_Exception_1, - User_Exception_2 : Exception; - - Saved_Occurrence : Exception_Occurrence; - Occurrence_Ptr : Exception_Occurrence_Access; - - User_Message : constant String := -- 200 character string. - "The string returned by Exception_Message may be tr" & - "uncated (to no less then 200 characters) by the Sa" & - "ve_Occurrence procedure (not the function), the Re" & - "raise_Occurrence proc, and the re-raise statement."; - - begin - - Raise_And_Save_Block_1 : - begin - - -- This nested exception structure is designed to ensure that the - -- appropriate exception occurrence is saved using the - -- Save_Occurrence procedure. - - raise Program_Error; - Report.Failed("Program_Error not raised"); - - exception - when Program_Error => - - begin - -- Use the procedure Raise_Exception, along with the 'Identity - -- attribute to raise the first user defined exception. Note - -- that a 200 character message is included in the call. - - Raise_Exception(User_Exception_1'Identity, User_Message); - Report.Failed("User_Exception_1 not raised"); - - exception - when Exc : User_Exception_1 => - - -- This exception occurrence is saved into a variable using - -- procedure Save_Occurrence. This saved occurrence should - -- not be confused with the raised occurrence of - -- Program_Error above. - - Save_Occurrence(Target => Saved_Occurrence, Source => Exc); - - when others => - Report.Failed("Unexpected exception handled, expecting " & - "User_Exception_1"); - end; - - when others => - Report.Failed("Incorrect exception generated by raise statement"); - - end Raise_And_Save_Block_1; - - - Reraise_And_Handle_Saved_Exception_1 : - begin - -- Reraise the exception that was saved in the previous block. - - Reraise_Occurrence(X => Saved_Occurrence); - - exception - when Exc : User_Exception_1 => -- Expected exception. - -- Check the exception id of the handled id by using the - -- Exception_Identity function, and compare with the id of the - -- originally raised exception. - - if User_Exception_1'Identity /= Exception_Identity(Exc) then - Report.Failed("Exception_Ids do not match - 1"); - end if; - - -- Check that the message associated with this exception occurrence - -- has not been truncated (it was originally 200 characters). - - if User_Message /= Exception_Message(Exc) then - Report.Failed("Exception messages do not match - 1"); - end if; - - when others => - Report.Failed - ("Incorrect exception raised by Reraise_Occurrence - 1"); - end Reraise_And_Handle_Saved_Exception_1; - - - Raise_And_Save_Block_2 : - begin - - Raise_Exception(User_Exception_2'Identity, User_Message); - Report.Failed("User_Exception_2 not raised"); - - exception - when Exc : User_Exception_2 => - - -- This exception occurrence is saved into an access object - -- using function Save_Occurrence. - - Occurrence_Ptr := Save_Occurrence(Source => Exc); - - when others => - Report.Failed("Unexpected exception handled, expecting " & - "User_Exception_2"); - end Raise_And_Save_Block_2; - - - Reraise_And_Handle_Saved_Exception_2 : - begin - -- Reraise the exception that was saved in the previous block. - -- Dereference the access object for use as input parameter. - - Reraise_Occurrence(X => Occurrence_Ptr.all); - - exception - when Exc : User_Exception_2 => -- Expected exception. - -- Check the exception id of the handled id by using the - -- Exception_Identity function, and compare with the id of the - -- originally raised exception. - - if User_Exception_2'Identity /= Exception_Identity(Exc) then - Report.Failed("Exception_Ids do not match - 2"); - end if; - - -- Check that the message associated with this exception occurrence - -- has not been truncated (it was originally 200 characters). - - if User_Message /= Exception_Message(Exc) then - Report.Failed("Exception messages do not match - 2"); - end if; - - when others => - Report.Failed - ("Incorrect exception raised by Reraise_Occurrence - 2"); - end Reraise_And_Handle_Saved_Exception_2; - - - -- Another example of the use of saving an exception occurrence - -- is demonstrated in the following block, where the ability to - -- save an occurrence into a data structure, for later processing, - -- is modeled. - - Store_And_Handle_Block: - declare - - Exc_Number : constant := 3; - Exception_1, - Exception_2, - Exception_3 : exception; - - Exception_Storage : array (1..Exc_Number) of Exception_Occurrence; - Messages : array (1..Exc_Number) of String(1..9) := - ("Message 1", "Message 2", "Message 3"); - - begin - - Outer_Block: - begin - - Inner_Block: - begin - - for i in 1..Exc_Number loop - begin - - begin - -- Exceptions all raised in a deep scope. - if i = 1 then - Raise_Exception(Exception_1'Identity, Messages(i)); - elsif i = 2 then - Raise_Exception(Exception_2'Identity, Messages(i)); - elsif i = 3 then - Raise_Exception(Exception_3'Identity, Messages(i)); - end if; - Report.Failed("Exception not raised on loop #" & - Integer'Image(i)); - end; - Report.Failed("Exception not propagated on loop #" & - Integer'Image(i)); - exception - when Exc : others => - - -- Save each occurrence into a storage array for - -- later processing. - - Save_Occurrence(Exception_Storage(i), Exc); - end; - end loop; - - end Inner_Block; - end Outer_Block; - - -- Raise the exceptions from the stored occurrences, and handle. - - for i in 1..Exc_Number loop - begin - Reraise_Occurrence(Exception_Storage(i)); - Report.Failed("No exception reraised for " & - "exception #" & Integer'Image(i)); - exception - when Exc : others => - -- The following sequence of checks ensures that the - -- correct occurrence was stored, and the associated - -- exception was raised and handled in the proper order. - if i = 1 then - if Exception_1'Identity /= Exception_Identity(Exc) then - Report.Failed("Exception_1 not raised"); - end if; - elsif i = 2 then - if Exception_2'Identity /= Exception_Identity(Exc) then - Report.Failed("Exception_2 not raised"); - end if; - elsif i = 3 then - if Exception_3'Identity /= Exception_Identity(Exc) then - Report.Failed("Exception_3 not raised"); - end if; - end if; - - if Exception_Message(Exc) /= Messages(i) then - Report.Failed("Incorrect message associated with " & - "exception #" & Integer'Image(i)); - end if; - end; - end loop; - exception - when others => - Report.Failed("Unexpected exception in Store_And_Handle_Block"); - end Store_And_Handle_Block; - - - Reraise_Out_Of_Scope: - declare - - TC_Value : constant := 5; - The_Exception : exception; - Saved_Exc_Occ : Exception_Occurrence; - - procedure Handle_It (Exc_Occ : in Exception_Occurrence) is - Must_Be_Raised : exception; - begin - if Exception_Identity(Exc_Occ) = The_Exception'Identity then - raise Must_Be_Raised; - Report.Failed("Exception Must_Be_Raised was not raised"); - else - Report.Failed("Incorrect exception handled in " & - "Procedure Handle_It"); - end if; - end Handle_It; - - begin - - if Report.Ident_Int(5) = TC_Value then - raise The_Exception; - end if; - - exception - when Exc : others => - Save_Occurrence (Saved_Exc_Occ, Exc); - begin - Handle_It(Saved_Exc_Occ); -- Raise another exception, in a - exception -- different scope. - when others => -- Handle this new exception. - begin - Reraise_Occurrence (Saved_Exc_Occ); -- Reraise the - -- original excptn. - Report.Failed("Saved Exception was not raised"); - exception - when Exc_2 : others => - if Exception_Identity (Exc_2) /= - The_Exception'Identity - then - Report.Failed - ("Incorrect exception occurrence reraised"); - end if; - end; - end; - end Reraise_Out_Of_Scope; - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CB41003; diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41004.a b/gcc/testsuite/ada/acats/tests/cb/cb41004.a deleted file mode 100644 index 09dfa9bfabc..00000000000 --- a/gcc/testsuite/ada/acats/tests/cb/cb41004.a +++ /dev/null @@ -1,316 +0,0 @@ --- CB41004.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 Raise_Exception and Reraise_Occurrence have no effect in --- the case of Null_Id or Null_Occurrence. Check that Exception_Message, --- Exception_Identity, Exception_Name, and Exception_Information raise --- Constraint_Error for a Null_Occurrence input parameter. --- Check that calling the Save_Occurrence subprograms with the --- Null_Occurrence input parameter saves the Null_Occurrence to the --- appropriate target object, and does not raise Constraint_Error. --- Check that Null_Id is the default initial value of type Exception_Id. --- --- TEST DESCRIPTION: --- This test performs a series of calls to many of the subprograms --- defined in package Ada.Exceptions, using either Null_Id or --- Null_Occurrence (based on their parameter profile). In the cases of --- Raise_Exception and Reraise_Occurrence, these null input values --- should result in no exceptions being raised, and Constraint_Error --- should not be raised in response to these calls. Test failure will --- result if any exception is raised in these cases. --- For the Save_Occurrence subprograms, calling them with the --- Null_Occurrence input parameter does not raise Constraint_Error, but --- simply results in the Null_Occurrence being saved into the appropriate --- target (either a Exception_Occurrence out parameter, or as an --- Exception_Occurrence_Access value). --- In the cases of the other mentioned subprograms, calls performed with --- a Null_Occurrence input parameter must result in Constraint_Error --- being raised. This exception will be handled, with test failure the --- result if the exception is not raised. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 08 Dec 00 RLB Removed Exception_Identity subtest, pending --- resolution of AI95-00241. --- Notes for future: Replace Exception_Identity --- subtest with whatever the resolution is. --- Add a subtest for Exception_Name(Null_Id), which --- is missing from this test. ---! - -with Report; -with Ada.Exceptions; - -procedure CB41004 is -begin - - Report.Test ("CB41004", "Check that Null_Id and Null_Occurrence input " & - "parameters have the appropriate effect when " & - "used in calls of the subprograms found in " & - "package Ada.Exceptions"); - - Test_Block: - declare - - use Ada.Exceptions; - - -- No initial values given for these two declarations; they default - -- to Null_Id and Null_Occurrence respectively. - A_Null_Exception_Id : Ada.Exceptions.Exception_Id; - A_Null_Exception_Occurrence : Ada.Exceptions.Exception_Occurrence; - - TC_Flag : Boolean := False; - - begin - - -- Verify that Null_Id is the default initial value of type - -- Exception_Id. - - if not (A_Null_Exception_Id = Ada.Exceptions.Null_Id) then - Report.Failed("The default initial value of an object of type " & - "Exception_Id was not Null_Id"); - end if; - - - -- Verify that Raise_Exception has no effect in the case of Null_Id. - begin - Ada.Exceptions.Raise_Exception(A_Null_Exception_Id); - TC_Flag := True; - exception - when others => - Report.Failed("Exception raised by procedure Raise_Exception " & - "when called with a Null_Id input parameter"); - end; - - if not TC_Flag then - Report.Failed("Incorrect processing following the call to " & - "Raise_Exception with a Null_Id input parameter"); - end if; - TC_Flag := False; - - - -- Verify that Reraise_Occurrence has no effect in the case of - -- Null_Occurrence. - begin - Ada.Exceptions.Reraise_Occurrence(A_Null_Exception_Occurrence); - TC_Flag := True; - exception - when others => - Report.Failed - ("Exception raised by procedure Reraise_Occurrence " & - "when called with a Null_Occurrence input parameter"); - end; - - if not TC_Flag then - Report.Failed("Incorrect processing following the call to " & - "Reraise_Occurrence with a Null_Occurrence " & - "input parameter"); - end if; - - - -- Verify that function Exception_Message raises Constraint_Error for - -- a Null_Occurrence input parameter. - begin - declare - Msg : constant String := - Ada.Exceptions.Exception_Message(A_Null_Exception_Occurrence); - begin - Report.Failed - ("Constraint_Error not raised by Function Exception_Message " & - "when called with a Null_Occurrence input parameter"); - end; - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Unexpected exception raised by Function Exception_Message " & - "when called with a Null_Occurrence input parameter"); - end; - - --- -- Verify that function Exception_Identity raises Constraint_Error for --- -- a Null_Occurrence input parameter. --- -- Note: (RLB, 2000/12/08) This behavior may be modified by AI-00241. --- -- As such, this test case has been removed pending a resolution. --- begin --- declare --- Id : Ada.Exceptions.Exception_Id := --- Ada.Exceptions.Exception_Identity(A_Null_Exception_Occurrence); --- begin --- Report.Failed --- ("Constraint_Error not raised by Function Exception_Identity " & --- "when called with a Null_Occurrence input parameter"); --- end; --- exception --- when Constraint_Error => null; -- OK, expected exception. --- when others => --- Report.Failed --- ("Unexpected exception raised by Function Exception_Identity " & --- "when called with a Null_Occurrence input parameter"); --- end; - - - -- Verify that function Exception_Name raises Constraint_Error for - -- a Null_Occurrence input parameter. - begin - declare - Name : constant String := - Ada.Exceptions.Exception_Name(A_Null_Exception_Occurrence); - begin - Report.Failed - ("Constraint_Error not raised by Function Exception_Name " & - "when called with a Null_Occurrence input parameter"); - end; - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Unexpected exception raised by Function Exception_Null " & - "when called with a Null_Occurrence input parameter"); - end; - - - -- Verify that function Exception_Information raises Constraint_Error - -- for a Null_Occurrence input parameter. - begin - declare - Info : constant String := - Ada.Exceptions.Exception_Information - (A_Null_Exception_Occurrence); - begin - Report.Failed - ("Constraint_Error not raised by Function " & - "Exception_Information when called with a " & - "Null_Occurrence input parameter"); - end; - exception - when Constraint_Error => null; -- OK, expected exception. - when others => - Report.Failed - ("Unexpected exception raised by Function Exception_Null " & - "when called with a Null_Occurrence input parameter"); - end; - - - -- Verify that calling the Save_Occurrence procedure with a - -- Null_Occurrence input parameter saves the Null_Occurrence to the - -- target object, and does not raise Constraint_Error. - declare - use Ada.Exceptions; - Saved_Occurrence : Exception_Occurrence; - begin - - -- Initialize the Saved_Occurrence variable with a value other than - -- Null_Occurrence (default). - begin - raise Program_Error; - exception - when Exc : others => Save_Occurrence(Saved_Occurrence, Exc); - end; - - -- Save a Null_Occurrence input parameter. - begin - Save_Occurrence(Target => Saved_Occurrence, - Source => Ada.Exceptions.Null_Occurrence); - exception - when others => - Report.Failed - ("Unexpected exception raised by procedure " & - "Save_Occurrence when called with a Null_Occurrence " & - "input parameter"); - end; - - -- Verify that the occurrence that was saved above is a - -- Null_Occurrence value. - - begin - Reraise_Occurrence(Saved_Occurrence); - exception - when others => - Report.Failed("Value saved from Procedure Save_Occurrence " & - "resulted in an exception, i.e., was not a " & - "value of Null_Occurrence"); - end; - - exception - when others => - Report.Failed("Unexpected exception raised during evaluation " & - "of Procedure Save_Occurrence"); - end; - - - -- Verify that calling the Save_Occurrence function with a - -- Null_Occurrence input parameter returns the Null_Occurrence as the - -- function result, and does not raise Constraint_Error. - declare - Occurrence_Ptr : Ada.Exceptions.Exception_Occurrence_Access; - begin - -- Save a Null_Occurrence input parameter. - begin - Occurrence_Ptr := - Ada.Exceptions.Save_Occurrence(Ada.Exceptions.Null_Occurrence); - exception - when others => - Report.Failed - ("Unexpected exception raised by function " & - "Save_Occurrence when called with a Null_Occurrence " & - "input parameter"); - end; - - -- Verify that the occurrence that was saved above is a - -- Null_Occurrence value. - - begin - -- Dereferenced value of type Exception_Occurrence_Access - -- should be a Null_Occurrence value, based on the action - -- of Function Save_Occurrence above. Providing this as an - -- input parameter to Reraise_Exception should not result in - -- any exception being raised. - - Ada.Exceptions.Reraise_Occurrence(Occurrence_Ptr.all); - - exception - when others => - Report.Failed("Value saved from Function Save_Occurrence " & - "resulted in an exception, i.e., was not a " & - "value of Null_Occurrence"); - end; - exception - when others => - Report.Failed("Unexpected exception raised during evaluation " & - "of Function Save_Occurrence"); - end; - - - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end CB41004; |