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