| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- ADA.EXCEPTIONS.STREAM_ATTRIBUTES -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2021, 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; |
| |
| -- 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; |
