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