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