1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- ADA.EXCEPTIONS.STREAM_ATTRIBUTES -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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 63 -- we output the 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_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 function, 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 146 else 147 To := S'First - 2; 148 Next_String; 149 150 if S (From .. From + 15) /= "Exception name: " then 151 Bad_EO; 152 end if; 153 154 X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To))); 155 156 Next_String; 157 158 if From <= To and then S (From) = 'M' then 159 if S (From .. From + 8) /= "Message: " then 160 Bad_EO; 161 end if; 162 163 X.Msg_Length := To - From - 8; 164 X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To); 165 Next_String; 166 167 else 168 X.Msg_Length := 0; 169 end if; 170 171 X.Pid := 0; 172 173 if From <= To and then S (From) = 'P' then 174 if S (From .. From + 3) /= "PID:" then 175 Bad_EO; 176 end if; 177 178 From := From + 5; -- skip past PID: space 179 180 while From <= To loop 181 X.Pid := X.Pid * 10 + 182 (Character'Pos (S (From)) - Character'Pos ('0')); 183 From := From + 1; 184 end loop; 185 186 Next_String; 187 end if; 188 189 X.Num_Tracebacks := 0; 190 191 if From <= To then 192 if S (From .. To) /= "Call stack traceback locations:" then 193 Bad_EO; 194 end if; 195 196 Next_String; 197 loop 198 exit when From > To; 199 200 declare 201 Ch : Character; 202 C : Integer_Address; 203 N : Integer_Address; 204 205 begin 206 if S (From) /= '0' 207 or else S (From + 1) /= 'x' 208 then 209 Bad_EO; 210 else 211 From := From + 2; 212 end if; 213 214 C := 0; 215 while From <= To loop 216 Ch := S (From); 217 218 if Ch in '0' .. '9' then 219 N := 220 Character'Pos (S (From)) - Character'Pos ('0'); 221 222 elsif Ch in 'a' .. 'f' then 223 N := 224 Character'Pos (S (From)) - Character'Pos ('a') + 10; 225 226 elsif Ch = ' ' then 227 From := From + 1; 228 exit; 229 230 else 231 Bad_EO; 232 end if; 233 234 C := C * 16 + N; 235 236 From := From + 1; 237 end loop; 238 239 if X.Num_Tracebacks = Max_Tracebacks then 240 Bad_EO; 241 end if; 242 243 X.Num_Tracebacks := X.Num_Tracebacks + 1; 244 X.Tracebacks (X.Num_Tracebacks) := 245 TBE.TB_Entry_For (To_Address (C)); 246 end; 247 end loop; 248 end if; 249 250 -- If an exception was converted to a string, it must have 251 -- already been raised, so flag it accordingly and we are done. 252 253 X.Exception_Raised := True; 254 return X; 255 end if; 256 end String_To_EO; 257 258end Stream_Attributes; 259