diff gcc/ada/libgnat/a-exstat.adb @ 111:04ced10e8804

gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/libgnat/a-exstat.adb	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,266 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                     ADA.EXCEPTIONS.STREAM_ATTRIBUTES                     --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Warnings (Off);
+--  Allow withing of non-Preelaborated units in Ada 2005 mode where this
+--  package will be categorized as Preelaborate. See AI-362 for details.
+--  It is safe in the context of the run-time to violate the rules.
+
+with System.Exception_Table;  use System.Exception_Table;
+with System.Storage_Elements; use System.Storage_Elements;
+
+pragma Warnings (On);
+
+separate (Ada.Exceptions)
+package body Stream_Attributes is
+
+   -------------------
+   -- EId_To_String --
+   -------------------
+
+   function EId_To_String (X : Exception_Id) return String is
+   begin
+      if X = Null_Id then
+         return "";
+      else
+         return Exception_Name (X);
+      end if;
+   end EId_To_String;
+
+   ------------------
+   -- EO_To_String --
+   ------------------
+
+   --  We use the null string to represent the null occurrence, otherwise we
+   --  output the Untailored_Exception_Information string for the occurrence.
+
+   function EO_To_String (X : Exception_Occurrence) return String is
+   begin
+      if X.Id = Null_Id then
+         return "";
+      else
+         return Exception_Data.Untailored_Exception_Information (X);
+      end if;
+   end EO_To_String;
+
+   -------------------
+   -- String_To_EId --
+   -------------------
+
+   function String_To_EId (S : String) return Exception_Id is
+   begin
+      if S = "" then
+         return Null_Id;
+      else
+         return Exception_Id (Internal_Exception (S));
+      end if;
+   end String_To_EId;
+
+   ------------------
+   -- String_To_EO --
+   ------------------
+
+   function String_To_EO (S : String) return Exception_Occurrence is
+      From : Natural;
+      To   : Integer;
+
+      X    : aliased Exception_Occurrence;
+      --  This is the exception occurrence we will create
+
+      procedure Bad_EO;
+      pragma No_Return (Bad_EO);
+      --  Signal bad exception occurrence string
+
+      procedure Next_String;
+      --  On entry, To points to last character of previous line of the
+      --  message, terminated by LF. On return, From .. To are set to
+      --  specify the next string, or From > To if there are no more lines.
+
+      procedure Bad_EO is
+      begin
+         Raise_Exception
+           (Program_Error'Identity,
+            "bad exception occurrence in stream input");
+
+         --  The following junk raise of Program_Error is required because
+         --  this is a No_Return procedure, and unfortunately Raise_Exception
+         --  can return (this particular call can't, but the back end is not
+         --  clever enough to know that).
+
+         raise Program_Error;
+      end Bad_EO;
+
+      procedure Next_String is
+      begin
+         From := To + 2;
+
+         if From < S'Last then
+            To := From + 1;
+
+            while To < S'Last - 1 loop
+               if To >= S'Last then
+                  Bad_EO;
+               elsif S (To + 1) = ASCII.LF then
+                  exit;
+               else
+                  To := To + 1;
+               end if;
+            end loop;
+         end if;
+      end Next_String;
+
+   --  Start of processing for String_To_EO
+
+   begin
+      if S = "" then
+         return Null_Occurrence;
+      end if;
+
+      To := S'First - 2;
+      Next_String;
+
+      if S (From .. From + 6) /= "raised " then
+         Bad_EO;
+      end if;
+
+      declare
+         Name_Start : constant Positive := From + 7;
+      begin
+         From := Name_Start + 1;
+
+         while From < To and then S (From) /= ' ' loop
+            From := From + 1;
+         end loop;
+
+         X.Id :=
+           Exception_Id (Internal_Exception (S (Name_Start .. From - 1)));
+      end;
+
+      if From <= To then
+         if S (From .. From + 2) /= " : " then
+            Bad_EO;
+         end if;
+
+         X.Msg_Length := To - From - 2;
+         X.Msg (1 .. X.Msg_Length) := S (From + 3 .. To);
+
+      else
+         X.Msg_Length := 0;
+      end if;
+
+      Next_String;
+      X.Pid := 0;
+
+      if From <= To and then S (From) = 'P' then
+         if S (From .. From + 3) /= "PID:" then
+            Bad_EO;
+         end if;
+
+         From := From + 5; -- skip past PID: space
+
+         while From <= To loop
+            X.Pid := X.Pid * 10 +
+                       (Character'Pos (S (From)) - Character'Pos ('0'));
+            From := From + 1;
+         end loop;
+
+         Next_String;
+      end if;
+
+      X.Num_Tracebacks := 0;
+
+      if From <= To then
+         if S (From .. To) /= "Call stack traceback locations:" then
+            Bad_EO;
+         end if;
+
+         Next_String;
+         loop
+            exit when From > To;
+
+            declare
+               Ch : Character;
+               C  : Integer_Address;
+               N  : Integer_Address;
+
+            begin
+               if S (From) /= '0'
+                 or else S (From + 1) /= 'x'
+               then
+                  Bad_EO;
+               else
+                  From := From + 2;
+               end if;
+
+               C := 0;
+               while From <= To loop
+                  Ch := S (From);
+
+                  if Ch in '0' .. '9' then
+                     N :=
+                       Character'Pos (S (From)) - Character'Pos ('0');
+
+                  elsif Ch in 'a' .. 'f' then
+                     N :=
+                       Character'Pos (S (From)) - Character'Pos ('a') + 10;
+
+                  elsif Ch = ' ' then
+                     From := From + 1;
+                     exit;
+
+                  else
+                     Bad_EO;
+                  end if;
+
+                  C := C * 16 + N;
+
+                  From := From + 1;
+               end loop;
+
+               if X.Num_Tracebacks = Max_Tracebacks then
+                  Bad_EO;
+               end if;
+
+               X.Num_Tracebacks := X.Num_Tracebacks + 1;
+               X.Tracebacks (X.Num_Tracebacks) :=
+                 TBE.TB_Entry_For (To_Address (C));
+            end;
+         end loop;
+      end if;
+
+      --  If an exception was converted to a string, it must have
+      --  already been raised, so flag it accordingly and we are done.
+
+      X.Exception_Raised := True;
+      return X;
+   end String_To_EO;
+
+end Stream_Attributes;