Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-exstat.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;