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-2016, 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 Entry_Param
 112             | Number_Param
 113             | Timeout_Param
 114          =>
 115             return Input (Matches (2).First .. Matches (2).Last);
 116
 117          when others =>
 118             return Input (Matches (1).First .. Matches (1).Last);
 119       end case;
 120    end Get_Param;
 121
 122 --  Start of processing for Send_Trace
 123
 124 begin
 125    New_Line;
 126    Put_Line ("- Trace Debug Info ----------------");
 127    Put ("Caught event Id : ");
 128
 129    case Id is
 130       when M_Accept_Complete => Put ("M_Accept_Complete");
 131          New_Line;
 132          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 133                    & " completes accept on entry "
 134                    & Get_Param (Info_Trace, Entry_Param, 1) & " with "
 135                    & Get_Param (Info_Trace, Caller_Param, 1));
 136
 137       when M_Select_Else     => Put ("M_Select_Else");
 138          New_Line;
 139          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 140                    & " selects else statement");
 141
 142       when M_RDV_Complete    => Put ("M_RDV_Complete");
 143          New_Line;
 144          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 145                    & " completes rendezvous with "
 146                    & Get_Param (Info_Trace, Caller_Param, 1));
 147
 148       when M_Call_Complete   => Put ("M_Call_Complete");
 149          New_Line;
 150          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 151                    & " completes call");
 152
 153       when M_Delay           => Put ("M_Delay");
 154          New_Line;
 155          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 156                    & " completes delay "
 157                    & Get_Param (Info_Trace, Timeout_Param, 1));
 158
 159       when E_Missed          => Put ("E_Missed");
 160          New_Line;
 161          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 162                    & " got an invalid acceptor "
 163                    & Get_Param (Info_Trace, Acceptor_Param, 1));
 164
 165       when E_Timeout         => Put ("E_Timeout");
 166          New_Line;
 167          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 168                    & " ends select due to timeout ");
 169
 170       when E_Kill            => Put ("E_Kill");
 171          New_Line;
 172          Put_Line ("Asynchronous Transfer of Control on task "
 173                    & Get_Param (Info_Trace, Name_Param, 1));
 174
 175       when W_Delay           => Put ("W_Delay");
 176          New_Line;
 177          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 178                    & " sleeping "
 179                    & Get_Param (Info_Trace, Timeout_Param, 1)
 180                    & " seconds");
 181
 182       when WU_Delay           => Put ("WU_Delay");
 183          New_Line;
 184          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 185                    & " sleeping until "
 186                    & Get_Param (Info_Trace, Timeout_Param, 1));
 187
 188       when W_Call            => Put ("W_Call");
 189          New_Line;
 190          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 191                    & " calling entry "
 192                    & Get_Param (Info_Trace, Entry_Param, 1)
 193                    & " of "  & Get_Param (Info_Trace, Acceptor_Param, 1));
 194
 195       when W_Accept          => Put ("W_Accept");
 196          New_Line;
 197          Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 198               & " waiting on "
 199               & Get_Param (Info_Trace, Number_Param, 1)
 200               & " accept(s)"
 201               & ", " & Get_Param (Info_Trace, Entry_Param, 1));
 202          New_Line;
 203
 204       when W_Select          => Put ("W_Select");
 205          New_Line;
 206          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 207                    & " waiting on "
 208                    & Get_Param (Info_Trace, Number_Param, 1)
 209                    & " select(s)"
 210                       & ", " & Get_Param (Info_Trace, Entry_Param, 1));
 211          New_Line;
 212
 213       when W_Completion      => Put ("W_Completion");
 214          New_Line;
 215             Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 216                       & " waiting for completion ");
 217
 218       when WT_Select         => Put ("WT_Select");
 219          New_Line;
 220          Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 221               & " waiting " & Get_Param (Info_Trace, Timeout_Param, 1)
 222               & " seconds  on "
 223               & Get_Param (Info_Trace, Number_Param, 1)
 224               & " select(s)");
 225
 226          if Get_Param (Info_Trace, Number_Param, 1) /= "" then
 227             Put (", " & Get_Param (Info_Trace, Entry_Param, 1));
 228          end if;
 229
 230          New_Line;
 231
 232       when WT_Call           => Put ("WT_Call");
 233          New_Line;
 234          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 235                    & " calling entry "
 236                    & Get_Param (Info_Trace, Entry_Param, 1)
 237                    & " of "  & Get_Param (Info_Trace, Acceptor_Param, 1)
 238                    & " with timeout "
 239                    & Get_Param (Info_Trace, Timeout_Param, 1));
 240
 241       when WT_Completion     => Put ("WT_Completion");
 242          New_Line;
 243          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 244                    & " waiting "
 245                    & Get_Param (Info_Trace, Timeout_Param, 1)
 246                    & " for call completion");
 247
 248       when PO_Call           => Put ("PO_Call");
 249          New_Line;
 250          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 251                    & " calling protected entry  "
 252                    & Get_Param (Info_Trace, Entry_Param, 1));
 253
 254       when POT_Call          => Put ("POT_Call");
 255          New_Line;
 256          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 257                    & " calling protected entry  "
 258                    & Get_Param (Info_Trace, Entry_Param, 1)
 259                    & " with timeout "
 260                    & Get_Param (Info_Trace, Timeout_Param, 1));
 261
 262       when PO_Run            => Put ("PO_Run");
 263          New_Line;
 264          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 265                       & " running entry  "
 266                    & Get_Param (Info_Trace, Entry_Param, 1)
 267                    & " for "
 268                    & Get_Param (Info_Trace, Caller_Param, 1));
 269
 270       when PO_Done           => Put ("PO_Done");
 271          New_Line;
 272          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 273                    & " finished call from "
 274                    & Get_Param (Info_Trace, Caller_Param, 1));
 275
 276       when PO_Lock           => Put ("PO_Lock");
 277          New_Line;
 278          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 279                    & " took lock");
 280
 281       when PO_Unlock         => Put ("PO_Unlock");
 282          New_Line;
 283          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 284                    & " released lock");
 285
 286       when T_Create          => Put ("T_Create");
 287          New_Line;
 288          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 289                    & " created");
 290
 291       when T_Activate        => Put ("T_Activate");
 292          New_Line;
 293          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 294                    & " activated");
 295
 296       when T_Abort           => Put ("T_Abort");
 297          New_Line;
 298          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 299                    & " aborted by "
 300                    & Get_Param (Info_Trace, Parent_Param, 1));
 301
 302       when T_Terminate       => Put ("T_Terminate");
 303          New_Line;
 304          Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
 305                    & " terminated");
 306
 307       when others
 308         => Put ("Invalid Id");
 309    end case;
 310
 311    Put_Line ("  --> " & Info_Trace);
 312    Put_Line ("-----------------------------------");
 313    New_Line;
 314 end Send_Trace;