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-2003 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Exception_Table;  use System.Exception_Table;
  35 with System.Storage_Elements; use System.Storage_Elements;
  36
  37 separate (Ada.Exceptions)
  38 package body Stream_Attributes is
  39
  40    -------------------
  41    -- EId_To_String --
  42    -------------------
  43
  44    function EId_To_String (X : Exception_Id) return String is
  45    begin
  46       if X = Null_Id then
  47          return "";
  48       else
  49          return Exception_Name (X);
  50       end if;
  51    end EId_To_String;
  52
  53    ------------------
  54    -- EO_To_String --
  55    ------------------
  56
  57    --  We use the null string to represent the null occurrence, otherwise
  58    --  we output the Exception_Information string for the occurrence.
  59
  60    function EO_To_String (X : Exception_Occurrence) return String is
  61    begin
  62       if X.Id = Null_Id then
  63          return "";
  64       else
  65          return Exception_Information (X);
  66       end if;
  67    end EO_To_String;
  68
  69    -------------------
  70    -- String_To_EId --
  71    -------------------
  72
  73    function String_To_EId (S : String) return Exception_Id is
  74    begin
  75       if S = "" then
  76          return Null_Id;
  77       else
  78          return Exception_Id (Internal_Exception (S));
  79       end if;
  80    end String_To_EId;
  81
  82    ------------------
  83    -- String_To_EO --
  84    ------------------
  85
  86    function String_To_EO (S : String) return Exception_Occurrence is
  87       From : Natural;
  88       To   : Integer;
  89
  90       X    : aliased Exception_Occurrence;
  91       --  This is the exception occurrence we will create
  92
  93       procedure Bad_EO;
  94       pragma No_Return (Bad_EO);
  95       --  Signal bad exception occurrence string
  96
  97       procedure Next_String;
  98       --  On entry, To points to last character of previous line of the
  99       --  message, terminated by LF. On return, From .. To are set to
 100       --  specify the next string, or From > To if there are no more lines.
 101
 102       procedure Bad_EO is
 103       begin
 104          Raise_Exception
 105            (Program_Error'Identity,
 106             "bad exception occurrence in stream input");
 107
 108          --  The following junk raise of Program_Error is required because
 109          --  this is a No_Return function, and unfortunately Raise_Exception
 110          --  can return (this particular call can't, but the back end is not
 111          --  clever enough to know that).
 112
 113          raise Program_Error;
 114       end Bad_EO;
 115
 116       procedure Next_String is
 117       begin
 118          From := To + 2;
 119
 120          if From < S'Last then
 121             To := From + 1;
 122
 123             while To < S'Last - 1 loop
 124                if To >= S'Last then
 125                   Bad_EO;
 126                elsif S (To + 1) = ASCII.LF then
 127                   exit;
 128                else
 129                   To := To + 1;
 130                end if;
 131             end loop;
 132          end if;
 133       end Next_String;
 134
 135    --  Start of processing for String_To_EO
 136
 137    begin
 138       if S = "" then
 139          return Null_Occurrence;
 140
 141       else
 142          X.Cleanup_Flag := False;
 143
 144          To := S'First - 2;
 145          Next_String;
 146
 147          if S (From .. From + 15) /= "Exception name: " then
 148             Bad_EO;
 149          end if;
 150
 151          X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
 152
 153          Next_String;
 154
 155          if From <= To and then S (From) = 'M' then
 156             if S (From .. From + 8) /= "Message: " then
 157                Bad_EO;
 158             end if;
 159
 160             X.Msg_Length := To - From - 8;
 161             X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
 162             Next_String;
 163
 164          else
 165             X.Msg_Length := 0;
 166          end if;
 167
 168          X.Pid := 0;
 169
 170          if From <= To and then S (From) = 'P' then
 171             if S (From .. From + 3) /= "PID:" then
 172                Bad_EO;
 173             end if;
 174
 175             From := From + 5; -- skip past PID: space
 176
 177             while From <= To loop
 178                X.Pid := X.Pid * 10 +
 179                           (Character'Pos (S (From)) - Character'Pos ('0'));
 180                From := From + 1;
 181             end loop;
 182
 183             Next_String;
 184          end if;
 185
 186          X.Num_Tracebacks := 0;
 187
 188          if From <= To then
 189             if S (From .. To) /= "Call stack traceback locations:" then
 190                Bad_EO;
 191             end if;
 192
 193             Next_String;
 194             loop
 195                exit when From > To;
 196
 197                declare
 198                   Ch : Character;
 199                   C  : Integer_Address;
 200                   N  : Integer_Address;
 201
 202                begin
 203                   if S (From) /= '0'
 204                     or else S (From + 1) /= 'x'
 205                   then
 206                      Bad_EO;
 207                   else
 208                      From := From + 2;
 209                   end if;
 210
 211                   C := 0;
 212                   while From <= To loop
 213                      Ch := S (From);
 214
 215                      if Ch in '0' .. '9' then
 216                         N :=
 217                           Character'Pos (S (From)) - Character'Pos ('0');
 218
 219                      elsif Ch in 'a' .. 'f' then
 220                         N :=
 221                           Character'Pos (S (From)) - Character'Pos ('a') + 10;
 222
 223                      elsif Ch = ' ' then
 224                         From := From + 1;
 225                         exit;
 226
 227                      else
 228                         Bad_EO;
 229                      end if;
 230
 231                      C := C * 16 + N;
 232
 233                      From := From + 1;
 234                   end loop;
 235
 236                   if X.Num_Tracebacks = Max_Tracebacks then
 237                      Bad_EO;
 238                   end if;
 239
 240                   X.Num_Tracebacks := X.Num_Tracebacks + 1;
 241                   X.Tracebacks (X.Num_Tracebacks) :=
 242                     TBE.TB_Entry_For (To_Address (C));
 243                end;
 244             end loop;
 245          end if;
 246
 247          --  If an exception was converted to a string, it must have
 248          --  already been raised, so flag it accordingly and we are done.
 249
 250          X.Exception_Raised := True;
 251          return X;
 252       end if;
 253    end String_To_EO;
 254
 255 end Stream_Attributes;