1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T R A C E S . S E N D --
9 -- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This version is for all targets, provided that System.IO.Put_Line is
35 -- functional. It prints debug information to Standard Output
37 with System.IO; use System.IO;
38 with GNAT.Regpat; use GNAT.Regpat;
44 -- Prints debug information both in a human readable form
45 -- and in the form they are sent from upper layers.
47 separate (System.Traces.Format)
48 procedure Send_Trace (Id : Trace_T; Info : String) is
58 -- Type of parameter found in the message
60 Info_Trace : String_Trace := Format_Trace (Info);
63 (Input : String_Trace;
67 -- Extract a parameter from the given input string
74 (Input : String_Trace;
79 pragma Unreferenced (How_Many);
81 Matches : Match_Array (1 .. 2);
83 -- We need comments here ???
87 Match ("/N:([\w]+)", Input, Matches);
90 Match ("/C:([\w]+)", Input, Matches);
93 Match ("/E:([\s]*) +([0-9 ,]+)", Input, Matches);
96 Match ("/T:([\s]*) +([0-9]+.[0-9]+)", Input, Matches);
98 when Acceptor_Param =>
99 Match ("/A:([\w]+)", Input, Matches);
102 Match ("/P:([\w]+)", Input, Matches);
105 Match ("/#:([\s]*) +([0-9]+)", Input, Matches);
108 if Matches (1).First < Input'First then
113 when Timeout_Param | Entry_Param | Number_Param =>
114 return Input (Matches (2).First .. Matches (2).Last);
117 return Input (Matches (1).First .. Matches (1).Last);
121 -- Start of processing for Send_Trace
125 Put_Line ("- Trace Debug Info ----------------");
126 Put ("Caught event Id : ");
129 when M_Accept_Complete => Put ("M_Accept_Complete");
131 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
132 & " completes accept on entry "
133 & Get_Param (Info_Trace, Entry_Param, 1) & " with "
134 & Get_Param (Info_Trace, Caller_Param, 1));
136 when M_Select_Else => Put ("M_Select_Else");
138 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
139 & " selects else statement");
141 when M_RDV_Complete => Put ("M_RDV_Complete");
143 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
144 & " completes rendezvous with "
145 & Get_Param (Info_Trace, Caller_Param, 1));
147 when M_Call_Complete => Put ("M_Call_Complete");
149 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
150 & " completes call");
152 when M_Delay => Put ("M_Delay");
154 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
155 & " completes delay "
156 & Get_Param (Info_Trace, Timeout_Param, 1));
158 when E_Missed => Put ("E_Missed");
160 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
161 & " got an invalid acceptor "
162 & Get_Param (Info_Trace, Acceptor_Param, 1));
164 when E_Timeout => Put ("E_Timeout");
166 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
167 & " ends select due to timeout ");
169 when E_Kill => Put ("E_Kill");
171 Put_Line ("Asynchronous Transfer of Control on task "
172 & Get_Param (Info_Trace, Name_Param, 1));
174 when W_Delay => Put ("W_Delay");
176 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
178 & Get_Param (Info_Trace, Timeout_Param, 1)
181 when WU_Delay => Put ("WU_Delay");
183 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
185 & Get_Param (Info_Trace, Timeout_Param, 1));
187 when W_Call => Put ("W_Call");
189 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
191 & Get_Param (Info_Trace, Entry_Param, 1)
192 & " of " & Get_Param (Info_Trace, Acceptor_Param, 1));
194 when W_Accept => Put ("W_Accept");
196 Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
198 & Get_Param (Info_Trace, Number_Param, 1)
200 & ", " & Get_Param (Info_Trace, Entry_Param, 1));
203 when W_Select => Put ("W_Select");
205 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
207 & Get_Param (Info_Trace, Number_Param, 1)
209 & ", " & Get_Param (Info_Trace, Entry_Param, 1));
212 when W_Completion => Put ("W_Completion");
214 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
215 & " waiting for completion ");
217 when WT_Select => Put ("WT_Select");
219 Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
220 & " waiting " & Get_Param (Info_Trace, Timeout_Param, 1)
222 & Get_Param (Info_Trace, Number_Param, 1)
225 if Get_Param (Info_Trace, Number_Param, 1) /= "" then
226 Put (", " & Get_Param (Info_Trace, Entry_Param, 1));
231 when WT_Call => Put ("WT_Call");
233 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
235 & Get_Param (Info_Trace, Entry_Param, 1)
236 & " of " & Get_Param (Info_Trace, Acceptor_Param, 1)
238 & Get_Param (Info_Trace, Timeout_Param, 1));
240 when WT_Completion => Put ("WT_Completion");
242 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
244 & Get_Param (Info_Trace, Timeout_Param, 1)
245 & " for call completion");
247 when PO_Call => Put ("PO_Call");
249 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
250 & " calling protected entry "
251 & Get_Param (Info_Trace, Entry_Param, 1));
253 when POT_Call => Put ("POT_Call");
255 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
256 & " calling protected entry "
257 & Get_Param (Info_Trace, Entry_Param, 1)
259 & Get_Param (Info_Trace, Timeout_Param, 1));
261 when PO_Run => Put ("PO_Run");
263 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
265 & Get_Param (Info_Trace, Entry_Param, 1)
267 & Get_Param (Info_Trace, Caller_Param, 1));
269 when PO_Done => Put ("PO_Done");
271 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
272 & " finished call from "
273 & Get_Param (Info_Trace, Caller_Param, 1));
275 when PO_Lock => Put ("PO_Lock");
277 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
280 when PO_Unlock => Put ("PO_Unlock");
282 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
285 when T_Create => Put ("T_Create");
287 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
290 when T_Activate => Put ("T_Activate");
292 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
295 when T_Abort => Put ("T_Abort");
297 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
299 & Get_Param (Info_Trace, Parent_Param, 1));
301 when T_Terminate => Put ("T_Terminate");
303 Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
307 => Put ("Invalid Id");
310 Put_Line (" --> " & Info_Trace);
311 Put_Line ("-----------------------------------");