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