1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- ADA.EXCEPTIONS.STREAM_ATTRIBUTES -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, 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 32pragma 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 37with System.Exception_Table; use System.Exception_Table; 38with System.Storage_Elements; use System.Storage_Elements; 39 40pragma Warnings (On); 41 42separate (Ada.Exceptions) 43package 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 266end Stream_Attributes; 267