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-2009, 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          X.Cleanup_Flag := False;
 148
 149          To := S'First - 2;
 150          Next_String;
 151
 152          if S (From .. From + 15) /= "Exception name: " then
 153             Bad_EO;
 154          end if;
 155
 156          X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
 157
 158          Next_String;
 159
 160          if From <= To and then S (From) = 'M' then
 161             if S (From .. From + 8) /= "Message: " then
 162                Bad_EO;
 163             end if;
 164
 165             X.Msg_Length := To - From - 8;
 166             X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
 167             Next_String;
 168
 169          else
 170             X.Msg_Length := 0;
 171          end if;
 172
 173          X.Pid := 0;
 174
 175          if From <= To and then S (From) = 'P' then
 176             if S (From .. From + 3) /= "PID:" then
 177                Bad_EO;
 178             end if;
 179
 180             From := From + 5; -- skip past PID: space
 181
 182             while From <= To loop
 183                X.Pid := X.Pid * 10 +
 184                           (Character'Pos (S (From)) - Character'Pos ('0'));
 185                From := From + 1;
 186             end loop;
 187
 188             Next_String;
 189          end if;
 190
 191          X.Num_Tracebacks := 0;
 192
 193          if From <= To then
 194             if S (From .. To) /= "Call stack traceback locations:" then
 195                Bad_EO;
 196             end if;
 197
 198             Next_String;
 199             loop
 200                exit when From > To;
 201
 202                declare
 203                   Ch : Character;
 204                   C  : Integer_Address;
 205                   N  : Integer_Address;
 206
 207                begin
 208                   if S (From) /= '0'
 209                     or else S (From + 1) /= 'x'
 210                   then
 211                      Bad_EO;
 212                   else
 213                      From := From + 2;
 214                   end if;
 215
 216                   C := 0;
 217                   while From <= To loop
 218                      Ch := S (From);
 219
 220                      if Ch in '0' .. '9' then
 221                         N :=
 222                           Character'Pos (S (From)) - Character'Pos ('0');
 223
 224                      elsif Ch in 'a' .. 'f' then
 225                         N :=
 226                           Character'Pos (S (From)) - Character'Pos ('a') + 10;
 227
 228                      elsif Ch = ' ' then
 229                         From := From + 1;
 230                         exit;
 231
 232                      else
 233                         Bad_EO;
 234                      end if;
 235
 236                      C := C * 16 + N;
 237
 238                      From := From + 1;
 239                   end loop;
 240
 241                   if X.Num_Tracebacks = Max_Tracebacks then
 242                      Bad_EO;
 243                   end if;
 244
 245                   X.Num_Tracebacks := X.Num_Tracebacks + 1;
 246                   X.Tracebacks (X.Num_Tracebacks) :=
 247                     TBE.TB_Entry_For (To_Address (C));
 248                end;
 249             end loop;
 250          end if;
 251
 252          --  If an exception was converted to a string, it must have
 253          --  already been raised, so flag it accordingly and we are done.
 254
 255          X.Exception_Raised := True;
 256          return X;
 257       end if;
 258    end String_To_EO;
 259
 260 end Stream_Attributes;