File : s-tfsetr-default.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T R A C E S . S E N D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
10 -- --
11 -- GNARL 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 -- --
19 -- --
20 -- --
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 -- This version is for all targets, provided that System.IO.Put_Line is
33 -- functional. It prints debug information to Standard Output
34
35 with System.IO; use System.IO;
36 with System.Regpat; use System.Regpat;
37
38 ----------------
39 -- Send_Trace --
40 ----------------
41
42 -- Prints debug information both in a human readable form
43 -- and in the form they are sent from upper layers.
44
45 separate (System.Traces.Format)
46 procedure Send_Trace (Id : Trace_T; Info : String) is
47
48 type Param_Type is
49 (Name_Param,
50 Caller_Param,
51 Entry_Param,
52 Timeout_Param,
53 Acceptor_Param,
54 Parent_Param,
55 Number_Param);
56 -- Type of parameter found in the message
57
58 Info_Trace : String_Trace := Format_Trace (Info);
59
60 function Get_Param
61 (Input : String_Trace;
62 Param : Param_Type;
63 How_Many : Integer)
64 return String;
65 -- Extract a parameter from the given input string
66
67 ---------------
68 -- Get_Param --
69 ---------------
70
71 function Get_Param
72 (Input : String_Trace;
73 Param : Param_Type;
74 How_Many : Integer)
75 return String
76 is
77 pragma Unreferenced (How_Many);
78
79 Matches : Match_Array (1 .. 2);
80 begin
81 -- We need comments here ???
82
83 case Param is
84 when Name_Param =>
85 Match ("/N:([\w]+)", Input, Matches);
86
87 when Caller_Param =>
88 Match ("/C:([\w]+)", Input, Matches);
89
90 when Entry_Param =>
91 Match ("/E:([\s]*) +([0-9 ,]+)", Input, Matches);
92
93 when Timeout_Param =>
94 Match ("/T:([\s]*) +([0-9]+.[0-9]+)", Input, Matches);
95
96 when Acceptor_Param =>
97 Match ("/A:([\w]+)", Input, Matches);
98
99 when Parent_Param =>
100 Match ("/P:([\w]+)", Input, Matches);
101
102 when Number_Param =>
103 Match ("/#:([\s]*) +([0-9]+)", Input, Matches);
104 end case;
105
106 if Matches (1).First < Input'First then
107 return "";
108 end if;
109
110 case Param is
111 when Timeout_Param | Entry_Param | Number_Param =>
112 return Input (Matches (2).First .. Matches (2).Last);
113
114 when others =>
115 return Input (Matches (1).First .. Matches (1).Last);
116 end case;
117 end Get_Param;
118
119 -- Start of processing for Send_Trace
120
121 begin
122 New_Line;
123 Put_Line ("- Trace Debug Info ----------------");
124 Put ("Caught event Id : ");
125
126 case Id is
127 when M_Accept_Complete => Put ("M_Accept_Complete");
128 New_Line;
129 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
130 & " completes accept on entry "
131 & Get_Param (Info_Trace, Entry_Param, 1) & " with "
132 & Get_Param (Info_Trace, Caller_Param, 1));
133
134 when M_Select_Else => Put ("M_Select_Else");
135 New_Line;
136 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
137 & " selects else statement");
138
139 when M_RDV_Complete => Put ("M_RDV_Complete");
140 New_Line;
141 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
142 & " completes rendezvous with "
143 & Get_Param (Info_Trace, Caller_Param, 1));
144
145 when M_Call_Complete => Put ("M_Call_Complete");
146 New_Line;
147 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
148 & " completes call");
149
150 when M_Delay => Put ("M_Delay");
151 New_Line;
152 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
153 & " completes delay "
154 & Get_Param (Info_Trace, Timeout_Param, 1));
155
156 when E_Missed => Put ("E_Missed");
157 New_Line;
158 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
159 & " got an invalid acceptor "
160 & Get_Param (Info_Trace, Acceptor_Param, 1));
161
162 when E_Timeout => Put ("E_Timeout");
163 New_Line;
164 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
165 & " ends select due to timeout ");
166
167 when E_Kill => Put ("E_Kill");
168 New_Line;
169 Put_Line ("Asynchronous Transfer of Control on task "
170 & Get_Param (Info_Trace, Name_Param, 1));
171
172 when W_Delay => Put ("W_Delay");
173 New_Line;
174 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
175 & " sleeping "
176 & Get_Param (Info_Trace, Timeout_Param, 1)
177 & " seconds");
178
179 when WU_Delay => Put ("WU_Delay");
180 New_Line;
181 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
182 & " sleeping until "
183 & Get_Param (Info_Trace, Timeout_Param, 1));
184
185 when W_Call => Put ("W_Call");
186 New_Line;
187 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
188 & " calling entry "
189 & Get_Param (Info_Trace, Entry_Param, 1)
190 & " of " & Get_Param (Info_Trace, Acceptor_Param, 1));
191
192 when W_Accept => Put ("W_Accept");
193 New_Line;
194 Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
195 & " waiting on "
196 & Get_Param (Info_Trace, Number_Param, 1)
197 & " accept(s)"
198 & ", " & Get_Param (Info_Trace, Entry_Param, 1));
199 New_Line;
200
201 when W_Select => Put ("W_Select");
202 New_Line;
203 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
204 & " waiting on "
205 & Get_Param (Info_Trace, Number_Param, 1)
206 & " select(s)"
207 & ", " & Get_Param (Info_Trace, Entry_Param, 1));
208 New_Line;
209
210 when W_Completion => Put ("W_Completion");
211 New_Line;
212 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
213 & " waiting for completion ");
214
215 when WT_Select => Put ("WT_Select");
216 New_Line;
217 Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
218 & " waiting " & Get_Param (Info_Trace, Timeout_Param, 1)
219 & " seconds on "
220 & Get_Param (Info_Trace, Number_Param, 1)
221 & " select(s)");
222
223 if Get_Param (Info_Trace, Number_Param, 1) /= "" then
224 Put (", " & Get_Param (Info_Trace, Entry_Param, 1));
225 end if;
226
227 New_Line;
228
229 when WT_Call => Put ("WT_Call");
230 New_Line;
231 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
232 & " calling entry "
233 & Get_Param (Info_Trace, Entry_Param, 1)
234 & " of " & Get_Param (Info_Trace, Acceptor_Param, 1)
235 & " with timeout "
236 & Get_Param (Info_Trace, Timeout_Param, 1));
237
238 when WT_Completion => Put ("WT_Completion");
239 New_Line;
240 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
241 & " waiting "
242 & Get_Param (Info_Trace, Timeout_Param, 1)
243 & " for call completion");
244
245 when PO_Call => Put ("PO_Call");
246 New_Line;
247 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
248 & " calling protected entry "
249 & Get_Param (Info_Trace, Entry_Param, 1));
250
251 when POT_Call => Put ("POT_Call");
252 New_Line;
253 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
254 & " calling protected entry "
255 & Get_Param (Info_Trace, Entry_Param, 1)
256 & " with timeout "
257 & Get_Param (Info_Trace, Timeout_Param, 1));
258
259 when PO_Run => Put ("PO_Run");
260 New_Line;
261 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
262 & " running entry "
263 & Get_Param (Info_Trace, Entry_Param, 1)
264 & " for "
265 & Get_Param (Info_Trace, Caller_Param, 1));
266
267 when PO_Done => Put ("PO_Done");
268 New_Line;
269 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
270 & " finished call from "
271 & Get_Param (Info_Trace, Caller_Param, 1));
272
273 when PO_Lock => Put ("PO_Lock");
274 New_Line;
275 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
276 & " took lock");
277
278 when PO_Unlock => Put ("PO_Unlock");
279 New_Line;
280 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
281 & " released lock");
282
283 when T_Create => Put ("T_Create");
284 New_Line;
285 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
286 & " created");
287
288 when T_Activate => Put ("T_Activate");
289 New_Line;
290 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
291 & " activated");
292
293 when T_Abort => Put ("T_Abort");
294 New_Line;
295 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
296 & " aborted by "
297 & Get_Param (Info_Trace, Parent_Param, 1));
298
299 when T_Terminate => Put ("T_Terminate");
300 New_Line;
301 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
302 & " terminated");
303
304 when others
305 => Put ("Invalid Id");
306 end case;
307
308 Put_Line (" --> " & Info_Trace);
309 Put_Line ("-----------------------------------");
310 New_Line;
311 end Send_Trace;