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-- 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--  This version is for all targets, provided that System.IO.Put_Line is
33--  functional. It prints debug information to Standard Output
34
35with System.IO;     use System.IO;
36with 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
45separate (System.Traces.Format)
46procedure 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
121begin
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;
311end Send_Trace;
312