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-2005, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 pragma Warnings (Off);
  35 --  Allow withing of non-Preelaborated units in Ada 2005 mode where this
  36 --  package will be categorized as Preelaborate. See AI-362 for details.
  37 --  It is safe in the context of the run-time to violate the rules!
  38
  39 with System.Exception_Table;  use System.Exception_Table;
  40 with System.Storage_Elements; use System.Storage_Elements;
  41
  42 pragma Warnings (On);
  43
  44 separate (Ada.Exceptions)
  45 package body Stream_Attributes is
  46
  47    -------------------
  48    -- EId_To_String --
  49    -------------------
  50
  51    function EId_To_String (X : Exception_Id) return String is
  52    begin
  53       if X = Null_Id then
  54          return "";
  55       else
  56          return Exception_Name (X);
  57       end if;
  58    end EId_To_String;
  59
  60    ------------------
  61    -- EO_To_String --
  62    ------------------
  63
  64    --  We use the null string to represent the null occurrence, otherwise
  65    --  we output the Exception_Information string for the occurrence.
  66
  67    function EO_To_String (X : Exception_Occurrence) return String is
  68    begin
  69       if X.Id = Null_Id then
  70          return "";
  71       else
  72          return Exception_Information (X);
  73       end if;
  74    end EO_To_String;
  75
  76    -------------------
  77    -- String_To_EId --
  78    -------------------
  79
  80    function String_To_EId (S : String) return Exception_Id is
  81    begin
  82       if S = "" then
  83          return Null_Id;
  84       else
  85          return Exception_Id (Internal_Exception (S));
  86       end if;
  87    end String_To_EId;
  88
  89    ------------------
  90    -- String_To_EO --
  91    ------------------
  92
  93    function String_To_EO (S : String) return Exception_Occurrence is
  94       From : Natural;
  95       To   : Integer;
  96
  97       X    : aliased Exception_Occurrence;
  98       --  This is the exception occurrence we will create
  99
 100       procedure Bad_EO;
 101       pragma No_Return (Bad_EO);
 102       --  Signal bad exception occurrence string
 103
 104       procedure Next_String;
 105       --  On entry, To points to last character of previous line of the
 106       --  message, terminated by LF. On return, From .. To are set to
 107       --  specify the next string, or From > To if there are no more lines.
 108
 109       procedure Bad_EO is
 110       begin
 111          Raise_Exception
 112            (Program_Error'Identity,
 113             "bad exception occurrence in stream input");
 114
 115          --  The following junk raise of Program_Error is required because
 116          --  this is a No_Return function, and unfortunately Raise_Exception
 117          --  can return (this particular call can't, but the back end is not
 118          --  clever enough to know that).
 119
 120          raise Program_Error;
 121       end Bad_EO;
 122
 123       procedure Next_String is
 124       begin
 125          From := To + 2;
 126
 127          if From < S'Last then
 128             To := From + 1;
 129
 130             while To < S'Last - 1 loop
 131                if To >= S'Last then
 132                   Bad_EO;
 133                elsif S (To + 1) = ASCII.LF then
 134                   exit;
 135                else
 136                   To := To + 1;
 137                end if;
 138             end loop;
 139          end if;
 140       end Next_String;
 141
 142    --  Start of processing for String_To_EO
 143
 144    begin
 145       if S = "" then
 146          return Null_Occurrence;
 147
 148       else
 149          X.Cleanup_Flag := False;
 150
 151          To := S'First - 2;
 152          Next_String;
 153
 154          if S (From .. From + 15) /= "Exception name: " then
 155             Bad_EO;
 156          end if;
 157
 158          X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
 159
 160          Next_String;
 161
 162          if From <= To and then S (From) = 'M' then
 163             if S (From .. From + 8) /= "Message: " then
 164                Bad_EO;
 165             end if;
 166
 167             X.Msg_Length := To - From - 8;
 168             X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
 169             Next_String;
 170
 171          else
 172             X.Msg_Length := 0;
 173          end if;
 174
 175          X.Pid := 0;
 176
 177          if From <= To and then S (From) = 'P' then
 178             if S (From .. From + 3) /= "PID:" then
 179                Bad_EO;
 180             end if;
 181
 182             From := From + 5; -- skip past PID: space
 183
 184             while From <= To loop
 185                X.Pid := X.Pid * 10 +
 186                           (Character'Pos (S (From)) - Character'Pos ('0'));
 187                From := From + 1;
 188             end loop;
 189
 190             Next_String;
 191          end if;
 192
 193          X.Num_Tracebacks := 0;
 194
 195          if From <= To then
 196             if S (From .. To) /= "Call stack traceback locations:" then
 197                Bad_EO;
 198             end if;
 199
 200             Next_String;
 201             loop
 202                exit when From > To;
 203
 204                declare
 205                   Ch : Character;
 206                   C  : Integer_Address;
 207                   N  : Integer_Address;
 208
 209                begin
 210                   if S (From) /= '0'
 211                     or else S (From + 1) /= 'x'
 212                   then
 213                      Bad_EO;
 214                   else
 215                      From := From + 2;
 216                   end if;
 217
 218                   C := 0;
 219                   while From <= To loop
 220                      Ch := S (From);
 221
 222                      if Ch in '0' .. '9' then
 223                         N :=
 224                           Character'Pos (S (From)) - Character'Pos ('0');
 225
 226                      elsif Ch in 'a' .. 'f' then
 227                         N :=
 228                           Character'Pos (S (From)) - Character'Pos ('a') + 10;
 229
 230                      elsif Ch = ' ' then
 231                         From := From + 1;
 232                         exit;
 233
 234                      else
 235                         Bad_EO;
 236                      end if;
 237
 238                      C := C * 16 + N;
 239
 240                      From := From + 1;
 241                   end loop;
 242
 243                   if X.Num_Tracebacks = Max_Tracebacks then
 244                      Bad_EO;
 245                   end if;
 246
 247                   X.Num_Tracebacks := X.Num_Tracebacks + 1;
 248                   X.Tracebacks (X.Num_Tracebacks) :=
 249                     TBE.TB_Entry_For (To_Address (C));
 250                end;
 251             end loop;
 252          end if;
 253
 254          --  If an exception was converted to a string, it must have
 255          --  already been raised, so flag it accordingly and we are done.
 256
 257          X.Exception_Raised := True;
 258          return X;
 259       end if;
 260    end String_To_EO;
 261
 262 end Stream_Attributes;