------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- ADA.EXCEPTIONS.STREAM_ATTRIBUTES -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2019, 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 -- -- . -- -- -- -- 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; -- The occurrence we're crafting is not currently being -- propagated. X.Machine_Occurrence := System.Null_Address; -- 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;