gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cb/cb41002.a

   1 -- CB41002.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that the message string input parameter in a call to the
  28 --      Raise_Exception procedure is associated with the raised exception
  29 --      occurrence, and that the message string can be obtained using the
  30 --      Exception_Message function with the associated Exception_Occurrence
  31 --      object.  Check that Function Exception_Information is available
  32 --      to provide implementation-defined information about the exception
  33 --      occurrence.
  34 --
  35 -- TEST DESCRIPTION:
  36 --      This test checks that a message associated with a raised exception
  37 --      is propagated with the exception, and can be retrieved using the
  38 --      Exception_Message function.  The exception will be raised using the
  39 --      'Identity attribute as a parameter to the Raise_Exception procedure,
  40 --      and an associated message string will be provided.  The exception
  41 --      will be handled, and the message associated with the occurrence will
  42 --      be compared to the original source message (non-default).
  43 --
  44 --      The test also includes a simulated logging procedure
  45 --      (Check_Exception_Information) that checks that Exception_Information
  46 --      can be called.
  47 --
  48 --
  49 -- CHANGE HISTORY:
  50 --      06 Dec 94   SAIC    ACVC 2.0
  51 --      22 Jun 00   RLB     Added a check at Exception_Information can be
  52 --                          called.
  53 --
  54 --!
  55
  56 with Report;
  57 with Ada.Exceptions;
  58
  59 procedure CB41002 is
  60 begin
  61
  62    Report.Test ("CB41002", "Check that the message string input parameter " &
  63                            "in a call to the Raise_Exception procedure is " &
  64                            "associated with the raised exception "          &
  65                            "occurrence, and that the message string can "   &
  66                            "be obtained using the Exception_Message "       &
  67                            "function with the associated "                  &
  68                            "Exception_Occurrence object. Also check that "  &
  69                            "the Exception_Information function can be called");
  70
  71    Test_Block:
  72    declare
  73
  74       Number_Of_Exceptions : constant := 3;
  75
  76       User_Exception_1,
  77       User_Exception_2,
  78       User_Exception_3 : exception;
  79
  80       type String_Ptr is access String;
  81
  82       User_Messages : constant array (1..Number_Of_Exceptions)
  83         of String_Ptr :=
  84         (new String'("Msg"),
  85          new String'("This message will override the default "   &
  86                      "message provided by the implementation"),
  87          new String'("The message can be captured by procedure"  & -- 200 chars
  88                       " Exception_Message.  It is designed to b" &
  89                       "e exactly 200 characters in length, sinc" &
  90                       "e there is a permission  concerning the " &
  91                       "truncation of a message over 200 chars. "));
  92
  93       procedure Check_Exception_Information (
  94                  Occur : in Ada.Exceptions.Exception_Occurrence) is
  95           -- Simulates an error logging routine.
  96          Info : constant String :=
  97               Ada.Exceptions.Exception_Information (Occur);
  98          function Is_Substring_of (Target, Search : in String) return Boolean is
  99             -- Returns True if Search is a substring of Target, and False
 100             -- otherwise.
 101          begin
 102             for I in Report.Ident_Int(Target'First) ..
 103                      Target'Last - Search'Length + 1 loop
 104                if Target(I .. I+Search'Length-1) = Search then
 105                   return True;
 106                end if;
 107             end loop;
 108             return False;
 109          end Is_Substring_of;
 110       begin
 111          -- We can't display Info, as it often contains line breaks
 112          -- (confusing Report), and might look much like the failure of a test
 113          -- with an unhandled exception (thus confusing grading tools).
 114          --
 115          -- We don't particular care if the implementation advice is followed,
 116          -- but we make these checks to insure that a compiler cannot optimize
 117          -- away Info or the rest of this routine.
 118          if not Is_Substring_of (Info,
 119                        Ada.Exceptions.Exception_Name (Occur)) then
 120              Report.Comment ("Exception_Information does not contain " &
 121                              "Exception_Name - see 11.4.1(19)");
 122          elsif not Is_Substring_of (Info,
 123                        Ada.Exceptions.Exception_Message (Occur)) then
 124              Report.Comment ("Exception_Information does not contain " &
 125                              "Exception_Message - see 11.4.1(19)");
 126          end if;
 127       end Check_Exception_Information;
 128
 129    begin
 130
 131       for i in 1..Number_Of_Exceptions loop
 132          begin
 133
 134             -- Raise a user-defined exception with a specific message string.
 135             case i is
 136                when 1 =>
 137                   Ada.Exceptions.Raise_Exception(User_Exception_1'Identity,
 138                                                  User_Messages(i).all);
 139                when 2 =>
 140                   Ada.Exceptions.Raise_Exception(User_Exception_2'Identity,
 141                                                  User_Messages(i).all);
 142                when 3 =>
 143                   Ada.Exceptions.Raise_Exception(User_Exception_3'Identity,
 144                                                  User_Messages(i).all);
 145                when others =>
 146                   Report.Failed("Incorrect result from Case statement");
 147             end case;
 148
 149             Report.Failed
 150               ("Exception not raised by procedure Exception_With_Message " &
 151                "for User_Exception #" & Integer'Image(i));
 152
 153          exception
 154             when Excptn : others =>
 155
 156                begin
 157                   -- The message that is associated with the raising of each
 158                   -- exception is captured here using the Exception_Message
 159                   -- function.
 160
 161                   if User_Messages(i).all /=
 162                      Ada.Exceptions.Exception_Message(Excptn)
 163                   then
 164                      Report.Failed
 165                        ("Message captured from exception is not the "  &
 166                         "message provided when the exception was raised, " &
 167                         "User_Exception #" & Integer'Image(i));
 168                   end if;
 169
 170                   Check_Exception_Information(Excptn);
 171                end;
 172          end;
 173       end loop;
 174
 175
 176
 177       -- Verify that the exception specific message is carried across
 178       -- various boundaries:
 179
 180       begin
 181
 182          begin
 183             Ada.Exceptions.Raise_Exception(User_Exception_1'Identity,
 184                                            User_Messages(1).all);
 185             Report.Failed("User_Exception_1 not raised");
 186          end;
 187          Report.Failed("User_Exception_1 not propagated");
 188       exception
 189          when Excptn : User_Exception_1 =>
 190
 191             if User_Messages(1).all /=
 192                Ada.Exceptions.Exception_Message(Excptn)
 193             then
 194                Report.Failed("User_Message_1 not found");
 195             end if;
 196             Check_Exception_Information(Excptn);
 197
 198          when others => Report.Failed("Unexpected exception handled - 1");
 199       end;
 200
 201
 202
 203       begin
 204
 205          begin
 206             Ada.Exceptions.Raise_Exception(User_Exception_2'Identity,
 207                                            User_Messages(2).all);
 208             Report.Failed("User_Exception_2 not raised");
 209          exception
 210             when Exc : User_Exception_2 =>
 211
 212                -- The exception is reraised here; message should propagate
 213                -- with exception occurrence.
 214
 215                Ada.Exceptions.Reraise_Occurrence(Exc);
 216             when others => Report.Failed("User_Exception_2 not handled");
 217          end;
 218          Report.Failed("User_Exception_2 not propagated");
 219       exception
 220          when Excptn : User_Exception_2 =>
 221
 222             if User_Messages(2).all /=
 223                Ada.Exceptions.Exception_Message(Excptn)
 224             then
 225                Report.Failed("User_Message_2 not found");
 226             end if;
 227             Check_Exception_Information(Excptn);
 228
 229          when others => Report.Failed("Unexpected exception handled - 2");
 230       end;
 231
 232
 233       -- Check exception and message propagation across task boundaries.
 234
 235       declare
 236
 237          task Raise_An_Exception is  -- single task
 238             entry Raise_It;
 239          end Raise_An_Exception;
 240
 241          task body Raise_An_Exception is
 242          begin
 243             accept Raise_It do
 244                Ada.Exceptions.Raise_Exception(User_Exception_3'Identity,
 245                                               User_Messages(3).all);
 246             end Raise_It;
 247             Report.Failed("User_Exception_3 not raised");
 248          exception
 249             when Excptn : User_Exception_3 =>
 250                if User_Messages(3).all /=
 251                   Ada.Exceptions.Exception_Message(Excptn)
 252                then
 253                   Report.Failed
 254                     ("User_Message_3 not returned inside task body");
 255                end if;
 256                Check_Exception_Information(Excptn);
 257             when others =>
 258                Report.Failed("Incorrect exception raised in task body");
 259          end Raise_An_Exception;
 260
 261       begin
 262          Raise_An_Exception.Raise_It;  -- Exception will be propagated here.
 263          Report.Failed("User_Exception_3 not propagated to caller");
 264       exception
 265          when Excptn : User_Exception_3 =>
 266             if User_Messages(3).all /=
 267                Ada.Exceptions.Exception_Message(Excptn)
 268             then
 269                Report.Failed("User_Message_3 not returned to caller of task");
 270             end if;
 271             Check_Exception_Information(Excptn);
 272          when others =>
 273             Report.Failed("Incorrect exception raised by task");
 274       end;
 275
 276
 277    exception
 278       when others => Report.Failed ("Exception raised in Test_Block");
 279    end Test_Block;
 280
 281    Report.Result;
 282
 283 end CB41002;