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-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
  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;