gcc/ada/a-exstat.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                     ADA.EXCEPTIONS.STREAM_ATTRIBUTES                     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Warnings (Off);
  33 --  Allow withing of non-Preelaborated units in Ada 2005 mode where this
  34 --  package will be categorized as Preelaborate. See AI-362 for details.
  35 --  It is safe in the context of the run-time to violate the rules!
  36
  37 with System.Exception_Table;  use System.Exception_Table;
  38 with System.Storage_Elements; use System.Storage_Elements;
  39
  40 pragma Warnings (On);
  41
  42 separate (Ada.Exceptions)
  43 package body Stream_Attributes is
  44
  45    -------------------
  46    -- EId_To_String --
  47    -------------------
  48
  49    function EId_To_String (X : Exception_Id) return String is
  50    begin
  51       if X = Null_Id then
  52          return "";
  53       else
  54          return Exception_Name (X);
  55       end if;
  56    end EId_To_String;
  57
  58    ------------------
  59    -- EO_To_String --
  60    ------------------
  61
  62    --  We use the null string to represent the null occurrence, otherwise
  63    --  we output the Exception_Information string for the occurrence.
  64
  65    function EO_To_String (X : Exception_Occurrence) return String is
  66    begin
  67       if X.Id = Null_Id then
  68          return "";
  69       else
  70          return Exception_Information (X);
  71       end if;
  72    end EO_To_String;
  73
  74    -------------------
  75    -- String_To_EId --
  76    -------------------
  77
  78    function String_To_EId (S : String) return Exception_Id is
  79    begin
  80       if S = "" then
  81          return Null_Id;
  82       else
  83          return Exception_Id (Internal_Exception (S));
  84       end if;
  85    end String_To_EId;
  86
  87    ------------------
  88    -- String_To_EO --
  89    ------------------
  90
  91    function String_To_EO (S : String) return Exception_Occurrence is
  92       From : Natural;
  93       To   : Integer;
  94
  95       X    : aliased Exception_Occurrence;
  96       --  This is the exception occurrence we will create
  97
  98       procedure Bad_EO;
  99       pragma No_Return (Bad_EO);
 100       --  Signal bad exception occurrence string
 101
 102       procedure Next_String;
 103       --  On entry, To points to last character of previous line of the
 104       --  message, terminated by LF. On return, From .. To are set to
 105       --  specify the next string, or From > To if there are no more lines.
 106
 107       procedure Bad_EO is
 108       begin
 109          Raise_Exception
 110            (Program_Error'Identity,
 111             "bad exception occurrence in stream input");
 112
 113          --  The following junk raise of Program_Error is required because
 114          --  this is a No_Return function, and unfortunately Raise_Exception
 115          --  can return (this particular call can't, but the back end is not
 116          --  clever enough to know that).
 117
 118          raise Program_Error;
 119       end Bad_EO;
 120
 121       procedure Next_String is
 122       begin
 123          From := To + 2;
 124
 125          if From < S'Last then
 126             To := From + 1;
 127
 128             while To < S'Last - 1 loop
 129                if To >= S'Last then
 130                   Bad_EO;
 131                elsif S (To + 1) = ASCII.LF then
 132                   exit;
 133                else
 134                   To := To + 1;
 135                end if;
 136             end loop;
 137          end if;
 138       end Next_String;
 139
 140    --  Start of processing for String_To_EO
 141
 142    begin
 143       if S = "" then
 144          return Null_Occurrence;
 145
 146       else
 147          To := S'First - 2;
 148          Next_String;
 149
 150          if S (From .. From + 15) /= "Exception name: " then
 151             Bad_EO;
 152          end if;
 153
 154          X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
 155
 156          Next_String;
 157
 158          if From <= To and then S (From) = 'M' then
 159             if S (From .. From + 8) /= "Message: " then
 160                Bad_EO;
 161             end if;
 162
 163             X.Msg_Length := To - From - 8;
 164             X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
 165             Next_String;
 166
 167          else
 168             X.Msg_Length := 0;
 169          end if;
 170
 171          X.Pid := 0;
 172
 173          if From <= To and then S (From) = 'P' then
 174             if S (From .. From + 3) /= "PID:" then
 175                Bad_EO;
 176             end if;
 177
 178             From := From + 5; -- skip past PID: space
 179
 180             while From <= To loop
 181                X.Pid := X.Pid * 10 +
 182                           (Character'Pos (S (From)) - Character'Pos ('0'));
 183                From := From + 1;
 184             end loop;
 185
 186             Next_String;
 187          end if;
 188
 189          X.Num_Tracebacks := 0;
 190
 191          if From <= To then
 192             if S (From .. To) /= "Call stack traceback locations:" then
 193                Bad_EO;
 194             end if;
 195
 196             Next_String;
 197             loop
 198                exit when From > To;
 199
 200                declare
 201                   Ch : Character;
 202                   C  : Integer_Address;
 203                   N  : Integer_Address;
 204
 205                begin
 206                   if S (From) /= '0'
 207                     or else S (From + 1) /= 'x'
 208                   then
 209                      Bad_EO;
 210                   else
 211                      From := From + 2;
 212                   end if;
 213
 214                   C := 0;
 215                   while From <= To loop
 216                      Ch := S (From);
 217
 218                      if Ch in '0' .. '9' then
 219                         N :=
 220                           Character'Pos (S (From)) - Character'Pos ('0');
 221
 222                      elsif Ch in 'a' .. 'f' then
 223                         N :=
 224                           Character'Pos (S (From)) - Character'Pos ('a') + 10;
 225
 226                      elsif Ch = ' ' then
 227                         From := From + 1;
 228                         exit;
 229
 230                      else
 231                         Bad_EO;
 232                      end if;
 233
 234                      C := C * 16 + N;
 235
 236                      From := From + 1;
 237                   end loop;
 238
 239                   if X.Num_Tracebacks = Max_Tracebacks then
 240                      Bad_EO;
 241                   end if;
 242
 243                   X.Num_Tracebacks := X.Num_Tracebacks + 1;
 244                   X.Tracebacks (X.Num_Tracebacks) :=
 245                     TBE.TB_Entry_For (To_Address (C));
 246                end;
 247             end loop;
 248          end if;
 249
 250          --  If an exception was converted to a string, it must have
 251          --  already been raised, so flag it accordingly and we are done.
 252
 253          X.Exception_Raised := True;
 254          return X;
 255       end if;
 256    end String_To_EO;
 257
 258 end Stream_Attributes;