267 lines
8.3 KiB
Ada
267 lines
8.3 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
|
-- --
|
||
|
|
-- GNAT COMPILER COMPONENTS --
|
||
|
|
-- --
|
||
|
|
-- ADA.EXCEPTIONS.STREAM_ATTRIBUTES --
|
||
|
|
-- --
|
||
|
|
-- B o d y --
|
||
|
|
-- --
|
||
|
|
-- Copyright (C) 1992-2015, 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;
|