gcc/ada/s-tasdeb-vms.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
   4 --                                                                          --
   5 --                  S Y S T E M . T A S K I N G . D E B U G                 --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --          Copyright (C) 2008-2010, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT 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 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  OpenVMS Version
  33
  34 with Ada.Unchecked_Conversion;
  35 with Ada.Unchecked_Deallocation;
  36 with System.Aux_DEC;
  37 with System.CRTL;
  38 with System.Task_Primitives.Operations;
  39 package body System.Tasking.Debug is
  40
  41    package OSI renames System.OS_Interface;
  42    package STPO renames System.Task_Primitives.Operations;
  43
  44    use System.Aux_DEC;
  45
  46    --  Condition value type
  47
  48    subtype Cond_Value_Type is Unsigned_Longword;
  49
  50    type Trace_Flag_Set is array (Character) of Boolean;
  51
  52    Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
  53
  54    --  Print_Routine fuction codes
  55
  56    type Print_Functions is
  57      (No_Print, Print_Newline, Print_Control,
  58       Print_String, Print_Symbol, Print_FAO);
  59    for Print_Functions use
  60      (No_Print => 0, Print_Newline => 1, Print_Control => 2,
  61       Print_String => 3, Print_Symbol => 4, Print_FAO => 5);
  62
  63    --  Counted ascii type declarations
  64
  65    subtype Count_Type is Natural range 0 .. 255;
  66    for Count_Type'Object_Size use 8;
  67
  68    type ASCIC (Count : Count_Type) is record
  69       Text  : String (1 .. Count);
  70    end record;
  71
  72    for ASCIC use record
  73       Count at 0 range 0 .. 7;
  74    end record;
  75    pragma Pack (ASCIC);
  76
  77    type AASCIC is access ASCIC;
  78    for AASCIC'Size use 32;
  79
  80    type AASCIC_Array is array (Positive range <>) of AASCIC;
  81
  82    type ASCIC127 is record
  83       Count : Count_Type;
  84       Text  : String (1 .. 127);
  85    end record;
  86
  87    for ASCIC127 use record
  88       Count at 0 range 0 .. 7;
  89       Text  at 1 range 0 .. 127 * 8 - 1;
  90    end record;
  91
  92    --  DEBUG Event record types used to signal DEBUG about Ada events
  93
  94    type Debug_Event_Record is record
  95       Code     : Unsigned_Word; --  Event code that uniquely identifies event
  96       Flags    : Bit_Array_8;   --  Flag bits
  97       --                            Bit 0: This event allows a parameter list
  98       --                            Bit 1: Parameters are address expressions
  99       Sentinal : Unsigned_Byte; --  Sentinal valuye: Always K_EVENT_SENT
 100       TS_Kind  : Unsigned_Byte; --  DST type specification: Always K_TS_TASK
 101       DType    : Unsigned_Byte; --  DTYPE of parameter if of atomic data type
 102       --                            Always K_DTYPE_TASK
 103       MBZ      : Unsigned_Byte; --  Unused (must be zero)
 104       Minchr   : Count_Type;    --  Minimum chars needed to identify event
 105       Name     : ASCIC (31);    --  Event name uppercase only
 106       Help     : AASCIC;        --  Event description
 107    end record;
 108
 109    for Debug_Event_Record use record
 110       Code     at 0 range 0 .. 15;
 111       Flags    at 2 range 0 .. 7;
 112       Sentinal at 3 range 0 .. 7;
 113       TS_Kind  at 4 range 0 .. 7;
 114       Dtype    at 5 range 0 .. 7;
 115       MBZ      at 6 range 0 .. 7;
 116       Minchr   at 7 range 0 .. 7;
 117       Name     at 8 range 0 .. 32 * 8 - 1;
 118       Help     at 40 range 0 .. 31;
 119    end record;
 120
 121    type Ada_Event_Control_Block_Type is record
 122       Code      : Unsigned_Word;     --  Reserved and defined by DEBUG
 123       Unused1   : Unsigned_Byte;     --  Reserved and defined by DEBUG
 124       Sentinal  : Unsigned_Byte;     --  Reserved and defined by DEBUG
 125       Facility  : Unsigned_Word;     --  Reserved and defined by DEBUG
 126       Flags     : Unsigned_Word;     --  Reserved and defined by DEBUG
 127       Value     : Unsigned_Longword; --  Reserved and defined by DEBUG
 128       Unused2   : Unsigned_Longword; --  Reserved and defined by DEBUG
 129       Sigargs   : Unsigned_Longword;
 130       P1        : Unsigned_Longword;
 131       Sub_Event : Unsigned_Longword;
 132    end record;
 133
 134    for Ada_Event_Control_Block_Type use record
 135       Code      at 0 range 0 .. 15;
 136       Unused1   at 2 range 0 .. 7;
 137       Sentinal  at 3 range 0 .. 7;
 138       Facility  at 4 range 0 .. 15;
 139       Flags     at 6 range 0 .. 15;
 140       Value     at 8 range 0 .. 31;
 141       Unused2   at 12 range 0 .. 31;
 142       Sigargs   at 16 range 0 .. 31;
 143       P1        at 20 range 0 .. 31;
 144       Sub_Event at 24 range 0 .. 31;
 145    end record;
 146
 147    type Ada_Event_Control_Block_Access is access Ada_Event_Control_Block_Type;
 148    for Ada_Event_Control_Block_Access'Size use 32;
 149
 150    --  Print_Routine_Type with max optional parameters
 151
 152    type Print_Routine_Type is access procedure
 153      (Print_Function    : Print_Functions;
 154       Print_Subfunction : Print_Functions;
 155       P1                : Unsigned_Longword := 0;
 156       P2                : Unsigned_Longword := 0;
 157       P3                : Unsigned_Longword := 0;
 158       P4                : Unsigned_Longword := 0;
 159       P5                : Unsigned_Longword := 0;
 160       P6                : Unsigned_Longword := 0);
 161    for Print_Routine_Type'Size use 32;
 162
 163    ---------------
 164    -- Constants --
 165    ---------------
 166
 167    --  These are used to obtain and convert task values
 168    K_CVT_VALUE_NUM  : constant := 1;
 169    K_CVT_NUM_VALUE  : constant := 2;
 170    K_NEXT_TASK      : constant := 3;
 171
 172    --  These are used to ask ADA to display task information
 173    K_SHOW_TASK     : constant := 4;
 174    K_SHOW_STAT     : constant := 5;
 175    K_SHOW_DEADLOCK : constant := 6;
 176
 177    --  These are used to get and set various attributes of one or more tasks
 178    --    Task state
 179    --  K_GET_STATE  : constant := 7;
 180    --  K_GET_ACTIVE : constant := 8;
 181    --  K_SET_ACTIVE : constant := 9;
 182    K_SET_ABORT  : constant := 10;
 183    --  K_SET_HOLD   : constant := 11;
 184
 185    --    Task priority
 186    K_GET_PRIORITY      : constant := 12;
 187    K_SET_PRIORITY      : constant := 13;
 188    K_RESTORE_PRIORITY  : constant := 14;
 189
 190    --    Task registers
 191    --  K_GET_REGISTERS     : constant := 15;
 192    --  K_SET_REGISTERS     : constant := 16;
 193
 194    --  These are used to control definable events
 195    K_ENABLE_EVENT   : constant := 17;
 196    K_DISABLE_EVENT  : constant := 18;
 197    K_ANNOUNCE_EVENT : constant := 19;
 198
 199    --  These are used to control time-slicing.
 200    --  K_SHOW_TIME_SLICE : constant := 20;
 201    --  K_SET_TIME_SLICE  : constant := 21;
 202
 203    --  This is used to symbolize task stack addresses.
 204    --  K_SYMBOLIZE_ADDRESS : constant := 22;
 205
 206    K_GET_CALLER : constant := 23;
 207    --  This is used to obtain the task value of the caller task
 208
 209    --  Miscellaneous functions - see below for details
 210
 211    K_CLEANUP_EVENT  : constant := 24;
 212    K_SHOW_EVENT_DEF : constant := 25;
 213    --  K_CHECK_TASK_STACK : constant := 26;  --  why commented out ???
 214
 215    --  This is used to obtain the DBGEXT-interface revision level
 216    --  K_GET_DBGEXT_REV : constant := 27; -- why commented out ???
 217
 218    K_GET_STATE_1 : constant := 28;
 219    --  This is used to obtain additional state info, primarily for PCA
 220
 221    K_FIND_EVENT_BY_CODE : constant := 29;
 222    K_FIND_EVENT_BY_NAME : constant := 30;
 223    --  These are used to search for user-defined event entries
 224
 225    --  This is used to stop task schedulding. Why commented out ???
 226    --  K_STOP_ALL_OTHER_TASKS : constant := 31;
 227
 228    --  Debug event constants
 229
 230    K_TASK_NOT_EXIST  : constant := 3;
 231    K_SUCCESS         : constant := 1;
 232    K_EVENT_SENT      : constant := 16#9A#;
 233    K_TS_TASK         : constant := 18;
 234    K_DTYPE_TASK      : constant := 44;
 235
 236    --  Status signal constants
 237
 238    SS_BADPARAM       : constant := 20;
 239    SS_NORMAL         : constant := 1;
 240
 241    --  Miscellaneous mask constants
 242
 243    V_EVNT_ALL        : constant := 0;
 244    V_Full_Display    : constant := 11;
 245    V_Suppress_Header : constant := 13;
 246
 247    --  CMA constants (why are some commented out???)
 248
 249    CMA_C_DEBGET_GUARDSIZE     : constant := 1;
 250    CMA_C_DEBGET_IS_HELD       : constant := 2;
 251 --   CMA_C_DEBGET_IS_INITIAL    : constant := 3;
 252 --   CMA_C_DEBGET_NUMBER        : constant := 4;
 253    CMA_C_DEBGET_STACKPTR      : constant := 5;
 254    CMA_C_DEBGET_STACK_BASE    : constant := 6;
 255    CMA_C_DEBGET_STACK_TOP     : constant := 7;
 256    CMA_C_DEBGET_SCHED_STATE   : constant := 8;
 257    CMA_C_DEBGET_YELLOWSIZE    : constant := 9;
 258 --   CMA_C_DEBGET_BASE_PRIO     : constant := 10;
 259 --   CMA_C_DEBGET_REGS          : constant := 11;
 260 --   CMA_C_DEBGET_ALT_PENDING   : constant := 12;
 261 --   CMA_C_DEBGET_ALT_A_ENABLE  : constant := 13;
 262 --   CMA_C_DEBGET_ALT_G_ENABLE  : constant := 14;
 263 --   CMA_C_DEBGET_SUBSTATE      : constant := 15;
 264 --   CMA_C_DEBGET_OBJECT_ADDR   : constant := 16;
 265 --   CMA_C_DEBGET_THKIND        : constant := 17;
 266 --   CMA_C_DEBGET_DETACHED      : constant := 18;
 267    CMA_C_DEBGET_TCB_SIZE      : constant := 19;
 268 --   CMA_C_DEBGET_START_PC      : constant := 20;
 269 --   CMA_C_DEBGET_NEXT_PC       : constant := 22;
 270 --   CMA_C_DEBGET_POLICY        : constant := 23;
 271 --   CMA_C_DEBGET_STACK_YELLOW  : constant := 24;
 272 --   CMA_C_DEBGET_STACK_DEFAULT : constant := 25;
 273
 274    --  Miscellaneous counted ascii constants
 275
 276    Star     : constant AASCIC := new ASCIC'(2, ("* "));
 277    NoStar   : constant AASCIC := new ASCIC'(2, ("  "));
 278    Hold     : constant AASCIC := new ASCIC'(4, ("HOLD"));
 279    NoHold   : constant AASCIC := new ASCIC'(4, ("    "));
 280    Header   : constant AASCIC := new ASCIC '
 281      (60, ("  task id     pri hold state   substate          task object"));
 282    Empty_Text : constant AASCIC := new ASCIC (0);
 283
 284    --  DEBUG Ada tasking states equated to their GNAT tasking equivalents
 285
 286    Ada_State_Invalid_State     : constant AASCIC :=
 287      new ASCIC'(17, "Invalid state    ");
 288 --   Ada_State_Abnormal          : constant AASCIC :=
 289 --     new ASCIC'(17, "Abnormal         ");
 290    Ada_State_Aborting          : constant AASCIC :=
 291      new ASCIC'(17, "Aborting         "); --  Aborting (new)
 292 --   Ada_State_Completed_Abn     : constant AASCIC :=
 293 --     new ASCIC'(17, "Completed  [abn] ");
 294 --   Ada_State_Completed_Exc     : constant AASCIC :=
 295 --     new ASCIC'(17, "Completed  [exc] ");
 296    Ada_State_Completed         : constant AASCIC :=
 297      new ASCIC'(17, "Completed        "); --  Master_Completion_Sleep
 298    Ada_State_Runnable          : constant AASCIC :=
 299      new ASCIC'(17, "Runnable         "); --  Runnable
 300    Ada_State_Activating        : constant AASCIC :=
 301      new ASCIC'(17, "Activating       ");
 302    Ada_State_Accept            : constant AASCIC :=
 303      new ASCIC'(17, "Accept           "); --  Acceptor_Sleep
 304    Ada_State_Select_or_Delay   : constant AASCIC :=
 305      new ASCIC'(17, "Select or delay  "); --  Acceptor_Delay_Sleep
 306    Ada_State_Select_or_Term    : constant AASCIC :=
 307      new ASCIC'(17, "Select or term.  "); -- Terminate_Alternative
 308    Ada_State_Select_or_Abort   : constant AASCIC :=
 309      new ASCIC'(17, "Select or abort  "); --  Async_Select_Sleep (new)
 310 --   Ada_State_Select            : constant AASCIC :=
 311 --     new ASCIC'(17, "Select           ");
 312    Ada_State_Activating_Tasks  : constant AASCIC :=
 313      new ASCIC'(17, "Activating tasks "); --  Activator_Sleep
 314    Ada_State_Delay             : constant AASCIC :=
 315      new ASCIC'(17, "Delay            "); --  AST_Pending
 316 --   Ada_State_Dependents        : constant AASCIC :=
 317 --     new ASCIC'(17, "Dependents       ");
 318    Ada_State_Entry_Call        : constant AASCIC :=
 319      new ASCIC'(17, "Entry call       "); --  Entry_Caller_Sleep
 320    Ada_State_Cond_Entry_Call   : constant AASCIC :=
 321      new ASCIC'(17, "Cond. entry call "); --  Call.Mode.Conditional_Call
 322    Ada_State_Timed_Entry_Call  : constant AASCIC :=
 323      new ASCIC'(17, "Timed entry call "); --  Call.Mode.Timed_Call
 324    Ada_State_Async_Entry_Call  : constant AASCIC :=
 325      new ASCIC'(17, "Async entry call "); --  Call.Mode.Asynchronous_Call (new)
 326 --   Ada_State_Dependents_Exc    : constant AASCIC :=
 327 --     new ASCIC'(17, "Dependents [exc] ");
 328    Ada_State_IO_or_AST         : constant AASCIC :=
 329      new ASCIC'(17, "I/O or AST       "); --  AST_Server_Sleep
 330 --   Ada_State_Shared_Resource   : constant AASCIC :=
 331 --     new ASCIC'(17, "Shared resource  ");
 332    Ada_State_Not_Yet_Activated : constant AASCIC :=
 333      new ASCIC'(17, "Not yet activated"); --  Unactivated
 334 --   Ada_State_Terminated_Abn    : constant AASCIC :=
 335 --     new ASCIC'(17, "Terminated [abn] ");
 336 --   Ada_State_Terminated_Exc    : constant AASCIC :=
 337 --     new ASCIC'(17, "Terminated [exc] ");
 338    Ada_State_Terminated        : constant AASCIC :=
 339      new ASCIC'(17, "Terminated       "); --  Terminated
 340    Ada_State_Server            : constant AASCIC :=
 341      new ASCIC'(17, "Server           "); --  Servers
 342    Ada_State_Async_Hold        : constant AASCIC :=
 343      new ASCIC'(17, "Async_Hold       "); --  Async_Hold
 344
 345    --  Task state counted ascii constants
 346
 347    Debug_State_Emp : constant AASCIC := new ASCIC'(5, "     ");
 348    Debug_State_Run : constant AASCIC := new ASCIC'(5, "RUN  ");
 349    Debug_State_Rea : constant AASCIC := new ASCIC'(5, "READY");
 350    Debug_State_Sus : constant AASCIC := new ASCIC'(5, "SUSP ");
 351    Debug_State_Ter : constant AASCIC := new ASCIC'(5, "TERM ");
 352
 353    --  Priority order of event display
 354
 355    Global_Event_Display_Order : constant array (Event_Kind_Type)
 356      of Event_Kind_Type := (
 357       Debug_Event_Abort_Terminated,
 358       Debug_Event_Activating,
 359       Debug_Event_Dependents_Exception,
 360       Debug_Event_Exception_Terminated,
 361       Debug_Event_Handled,
 362       Debug_Event_Handled_Others,
 363       Debug_Event_Preempted,
 364       Debug_Event_Rendezvous_Exception,
 365       Debug_Event_Run,
 366       Debug_Event_Suspended,
 367       Debug_Event_Terminated);
 368
 369    --  Constant array defining all debug events
 370
 371    Event_Directory : constant array (Event_Kind_Type)
 372      of Debug_Event_Record := (
 373       (Debug_Event_Activating,
 374        (False, False, False, False, False, False, False, True),
 375        K_EVENT_SENT,
 376        K_TS_TASK,
 377        K_DTYPE_TASK,
 378        0,
 379        2,
 380        (31, "ACTIVATING                     "),
 381        new ASCIC'(41, "!_a task is about to begin its activation")),
 382
 383       (Debug_Event_Run,
 384        (False, False, False, False, False, False, False, True),
 385        K_EVENT_SENT,
 386        K_TS_TASK,
 387        K_DTYPE_TASK,
 388        0,
 389        2,
 390        (31, "RUN                            "),
 391        new ASCIC'(24, "!_a task is about to run")),
 392
 393       (Debug_Event_Suspended,
 394        (False, False, False, False, False, False, False, True),
 395        K_EVENT_SENT,
 396        K_TS_TASK,
 397        K_DTYPE_TASK,
 398        0,
 399        1,
 400        (31, "SUSPENDED                      "),
 401        new ASCIC'(33, "!_a task is about to be suspended")),
 402
 403       (Debug_Event_Preempted,
 404        (False, False, False, False, False, False, False, True),
 405        K_EVENT_SENT,
 406        K_TS_TASK,
 407        K_DTYPE_TASK,
 408        0,
 409        1,
 410        (31, "PREEMPTED                      "),
 411        new ASCIC'(33, "!_a task is about to be preempted")),
 412
 413       (Debug_Event_Terminated,
 414        (False, False, False, False, False, False, False, True),
 415        K_EVENT_SENT,
 416        K_TS_TASK,
 417        K_DTYPE_TASK,
 418        0,
 419        1,
 420        (31, "TERMINATED                     "),
 421        new ASCIC'(57,
 422         "!_a task is terminating (including by abort or exception)")),
 423
 424       (Debug_Event_Abort_Terminated,
 425        (False, False, False, False, False, False, False, True),
 426        K_EVENT_SENT,
 427        K_TS_TASK,
 428        K_DTYPE_TASK,
 429        0,
 430        2,
 431        (31, "ABORT_TERMINATED               "),
 432        new ASCIC'(40, "!_a task is terminating because of abort")),
 433
 434       (Debug_Event_Exception_Terminated,
 435        (False, False, False, False, False, False, False, True),
 436        K_EVENT_SENT,
 437        K_TS_TASK,
 438        K_DTYPE_TASK,
 439        0,
 440        1,
 441        (31, "EXCEPTION_TERMINATED           "),
 442        new ASCIC'(47, "!_a task is terminating because of an exception")),
 443
 444       (Debug_Event_Rendezvous_Exception,
 445        (False, False, False, False, False, False, False, True),
 446        K_EVENT_SENT,
 447        K_TS_TASK,
 448        K_DTYPE_TASK,
 449        0,
 450        3,
 451        (31, "RENDEZVOUS_EXCEPTION           "),
 452        new ASCIC'(49, "!_an exception is propagating out of a rendezvous")),
 453
 454       (Debug_Event_Handled,
 455        (False, False, False, False, False, False, False, True),
 456        K_EVENT_SENT,
 457        K_TS_TASK,
 458        K_DTYPE_TASK,
 459        0,
 460        1,
 461        (31, "HANDLED                        "),
 462        new ASCIC'(37, "!_an exception is about to be handled")),
 463
 464       (Debug_Event_Dependents_Exception,
 465        (False, False, False, False, False, False, False, True),
 466        K_EVENT_SENT,
 467        K_TS_TASK,
 468        K_DTYPE_TASK,
 469        0,
 470        1,
 471        (31, "DEPENDENTS_EXCEPTION           "),
 472        new ASCIC'(64,
 473         "!_an exception is about to cause a task to await dependent tasks")),
 474
 475       (Debug_Event_Handled_Others,
 476        (False, False, False, False, False, False, False, True),
 477        K_EVENT_SENT,
 478        K_TS_TASK,
 479        K_DTYPE_TASK,
 480        0,
 481        1,
 482        (31, "HANDLED_OTHERS                 "),
 483        new ASCIC'(58,
 484         "!_an exception is about to be handled in an OTHERS handler")));
 485
 486    --  Help on events displayed in DEBUG
 487
 488    Event_Def_Help : constant AASCIC_Array := (
 489      new ASCIC'(0,  ""),
 490      new ASCIC'(65,
 491       "  The general forms of commands to set a breakpoint or tracepoint"),
 492      new ASCIC'(22, "  on an Ada event are:"),
 493      new ASCIC'(73, "    SET BREAK/EVENT=event [task[, ... ]] " &
 494                     "[WHEN(expr)] [DO(comnd[; ... ])]"),
 495      new ASCIC'(73, "    SET TRACE/EVENT=event [task[, ... ]] " &
 496                     "[WHEN(expr)] [DO(comnd[; ... ])]"),
 497      new ASCIC'(0,  ""),
 498      new ASCIC'(65,
 499       "  If tasks are specified, the breakpoint will trigger only if the"),
 500      new ASCIC'(40, "  event occurs for those specific tasks."),
 501      new ASCIC'(0,  ""),
 502      new ASCIC'(39, "  Ada event names and their definitions"),
 503      new ASCIC'(0,  ""));
 504
 505    -----------------------
 506    -- Package Variables --
 507    -----------------------
 508
 509    AC_Buffer : ASCIC127;
 510
 511    Events_Enabled_Count : Integer := 0;
 512
 513    Print_Routine_Bufsiz : constant := 132;
 514    Print_Routine_Bufcnt : Integer := 0;
 515    Print_Routine_Linbuf : String (1 .. Print_Routine_Bufsiz);
 516
 517    Global_Task_Debug_Events : Debug_Event_Array :=
 518      (False, False, False, False, False, False, False, False,
 519       False, False, False, False, False, False, False, False);
 520    --  Global table of task debug events set by the debugger
 521
 522    --------------------------
 523    -- Exported Subprograms --
 524    --------------------------
 525
 526    procedure Default_Print_Routine
 527      (Print_Function    : Print_Functions;
 528       Print_Subfunction : Print_Functions;
 529       P1                : Unsigned_Longword := 0;
 530       P2                : Unsigned_Longword := 0;
 531       P3                : Unsigned_Longword := 0;
 532       P4                : Unsigned_Longword := 0;
 533       P5                : Unsigned_Longword := 0;
 534       P6                : Unsigned_Longword := 0);
 535    --  The default print routine if not overridden.
 536    --  Print_Function determines option argument formatting.
 537    --  Print_Subfunction buffers output if No_Print, calls Put_Output if
 538    --  Print_Newline
 539
 540    pragma Export_Procedure
 541      (Default_Print_Routine,
 542       Mechanism => (Value, Value, Reference, Reference, Reference));
 543
 544    --------------------------
 545    -- Imported Subprograms --
 546    --------------------------
 547
 548    procedure Debug_Get
 549      (Thread_Id : OSI.Thread_Id;
 550       Item_Req  : Unsigned_Word;
 551       Out_Buff  : System.Address;
 552       Buff_Siz  : Unsigned_Word);
 553
 554    procedure Debug_Get
 555      (Thread_Id : OSI.Thread_Id;
 556       Item_Req  : Unsigned_Word;
 557       Out_Buff  : Unsigned_Longword;
 558       Buff_Siz  : Unsigned_Word);
 559    pragma Interface (External, Debug_Get);
 560
 561    pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET",
 562      (OSI.Thread_Id, Unsigned_Word, System.Address, Unsigned_Word),
 563      (Reference, Value, Reference, Value));
 564
 565    pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET",
 566      (OSI.Thread_Id, Unsigned_Word, Unsigned_Longword, Unsigned_Word),
 567      (Reference, Value, Reference, Value));
 568
 569    procedure FAOL
 570      (Status : out Cond_Value_Type;
 571       Ctrstr : String;
 572       Outlen : out Unsigned_Word;
 573       Outbuf : out String;
 574       Prmlst : Unsigned_Longword_Array);
 575    pragma Interface (External, FAOL);
 576
 577    pragma Import_Valued_Procedure (FAOL, "SYS$FAOL",
 578      (Cond_Value_Type, String, Unsigned_Word, String, Unsigned_Longword_Array),
 579      (Value, Descriptor (S), Reference, Descriptor (S), Reference));
 580
 581    procedure Put_Output (
 582      Status         : out Cond_Value_Type;
 583      Message_String : String);
 584
 585    procedure Put_Output (Message_String : String);
 586    pragma Interface (External, Put_Output);
 587
 588    pragma Import_Valued_Procedure (Put_Output, "LIB$PUT_OUTPUT",
 589      (Cond_Value_Type, String),
 590      (Value, Short_Descriptor (S)));
 591
 592    pragma Import_Procedure (Put_Output, "LIB$PUT_OUTPUT",
 593      (String),
 594      (Short_Descriptor (S)));
 595
 596    procedure Signal
 597      (Condition_Value     : Cond_Value_Type;
 598       Number_Of_Arguments : Integer := Integer'Null_Parameter;
 599       FAO_Argument_1      : Unsigned_Longword :=
 600                               Unsigned_Longword'Null_Parameter);
 601    pragma Interface (External, Signal);
 602
 603    pragma Import_Procedure (Signal, "LIB$SIGNAL",
 604       (Cond_Value_Type, Integer, Unsigned_Longword),
 605       (Value, Value, Value),
 606        Number_Of_Arguments);
 607
 608    ----------------------------
 609    -- Generic Instantiations --
 610    ----------------------------
 611
 612    function Fetch is new Fetch_From_Address (Unsigned_Longword);
 613    pragma Unreferenced (Fetch);
 614
 615    procedure Free is new Ada.Unchecked_Deallocation
 616      (Object => Ada_Event_Control_Block_Type,
 617       Name   => Ada_Event_Control_Block_Access);
 618
 619    function To_AASCIC is new
 620      Ada.Unchecked_Conversion (Unsigned_Longword, AASCIC);
 621
 622    function To_Addr is new
 623      Ada.Unchecked_Conversion (Task_Procedure_Access, Address);
 624    pragma Unreferenced (To_Addr);
 625
 626    function To_EVCB is new
 627      Ada.Unchecked_Conversion
 628       (Unsigned_Longword, Ada_Event_Control_Block_Access);
 629
 630    function To_Integer is new
 631      Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address);
 632
 633    function To_Print_Routine_Type is new
 634      Ada.Unchecked_Conversion (Short_Address, Print_Routine_Type);
 635
 636    --  Optional argumements passed to Print_Routine have to be
 637    --  Unsigned_Longwords so define the required Unchecked_Conversions
 638
 639    function To_UL is new
 640      Ada.Unchecked_Conversion (AASCIC, Unsigned_Longword);
 641
 642    function To_UL is new
 643      Ada.Unchecked_Conversion (Integer, Unsigned_Longword);
 644
 645    function To_UL is new
 646      Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword);
 647
 648    pragma Warnings (Off); --  Different sizes
 649    function To_UL is new
 650      Ada.Unchecked_Conversion (Task_Entry_Index, Unsigned_Longword);
 651    pragma Warnings (On);
 652
 653    function To_UL is new
 654      Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword);
 655
 656    function To_UL is new
 657      Ada.Unchecked_Conversion
 658       (Ada_Event_Control_Block_Access, Unsigned_Longword);
 659
 660    -----------------------
 661    -- Local Subprograms --
 662    -----------------------
 663
 664    subtype Function_Codes is System.Aux_DEC.Unsigned_Word range 1 .. 31;
 665    --  The 31 function codes sent by the debugger needed to implement
 666    --  tasking support, enumerated below.
 667
 668    type Register_Array is array (Natural range 0 .. 16) of
 669      System.Aux_DEC.Unsigned_Longword;
 670    --  The register array is a holdover from VAX and not used
 671    --  on Alpha or I64 but is kept as a filler below.
 672
 673    type DBGEXT_Control_Block (Function_Code : Function_Codes) is record
 674       Facility_ID         : System.Aux_DEC.Unsigned_Word;
 675       --  For GNAT use the "Ada" facility ID
 676       Status              : System.Aux_DEC.Unsigned_Longword;
 677       --  Successful or otherwise returned status
 678       Flags               : System.Aux_DEC.Bit_Array_32;
 679       --   Used to flag event as global
 680       Print_Routine       : System.Aux_DEC.Short_Address;
 681       --  The print subprogram the caller wants to use for output
 682       Event_Code_or_EVCB  : System.Aux_DEC.Unsigned_Longword;
 683       --  Dual use Event Code or EVent Control Block
 684       Event_Value_or_Name : System.Aux_DEC.Unsigned_Longword;
 685       --  Dual use Event Value or Event Name string pointer
 686       Event_Entry         : System.Aux_DEC.Unsigned_Longword;
 687       Task_Value          : Task_Id;
 688       Task_Number         : Integer;
 689       Ada_Flags           : System.Aux_DEC.Bit_Array_32;
 690       Priority            : System.Aux_DEC.Bit_Array_32;
 691       Active_Registers    : System.Aux_DEC.Short_Address;
 692
 693       case Function_Code is
 694          when K_GET_STATE_1 =>
 695             Base_Priority       : System.Aux_DEC.Bit_Array_32;
 696             Task_Type_Name      : System.Aux_DEC.Short_Address;
 697             Creation_PC         : System.Aux_DEC.Short_Address;
 698             Parent_Task_ID      : Task_Id;
 699
 700          when others =>
 701             Ignored_Unused      : Register_Array;
 702
 703       end case;
 704    end record;
 705
 706    for DBGEXT_Control_Block use record
 707       Function_Code       at 0  range 0 .. 15;
 708       Facility_ID         at 2  range 0 .. 15;
 709       Status              at 4  range 0 .. 31;
 710       Flags               at 8  range 0 .. 31;
 711       Print_Routine       at 12 range 0 .. 31;
 712       Event_Code_or_EVCB  at 16 range 0 .. 31;
 713       Event_Value_or_Name at 20 range 0 .. 31;
 714       Event_Entry         at 24 range 0 .. 31;
 715       Task_Value          at 28 range 0 .. 31;
 716       Task_Number         at 32 range 0 .. 31;
 717       Ada_Flags           at 36 range 0 .. 31;
 718       Priority            at 40 range 0 .. 31;
 719       Active_Registers    at 44 range 0 .. 31;
 720       Ignored_Unused      at 48 range 0 .. 17 * 32 - 1;
 721       Base_Priority       at 48 range 0 .. 31;
 722       Task_Type_Name      at 52 range 0 .. 31;
 723       Creation_PC         at 56 range 0 .. 31;
 724       Parent_Task_ID      at 60 range 0 .. 31;
 725    end record;
 726
 727    type DBGEXT_Control_Block_Access is access all DBGEXT_Control_Block;
 728
 729    function DBGEXT (Control_Block : DBGEXT_Control_Block_Access)
 730      return System.Aux_DEC.Unsigned_Word;
 731    --  Exported to s-taprop.adb to avoid having a VMS specific s-tasdeb.ads
 732    pragma Convention (C, DBGEXT);
 733    pragma Export_Function (DBGEXT, "GNAT$DBGEXT");
 734    --  This routine is called by CMA when VMS DEBUG wants the Gnat RTL
 735    --  to give it some assistance (primarily when tasks are debugged).
 736    --
 737    --  The single parameter is an "external control block". On input to
 738    --  the Gnat RTL this control block determines the debugging function
 739    --  to be performed, and supplies parameters.  This routine cases on
 740    --  the function code, and calls the appropriate Gnat RTL routine,
 741    --  which returns values by modifying the external control block.
 742
 743    procedure Announce_Event
 744       (Event_EVCB    : Unsigned_Longword;
 745        Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
 746    --  Announce the occurence of a DEBUG tasking event
 747
 748    procedure Cleanup_Event (Event_EVCB : Unsigned_Longword);
 749    --  After DEBUG has processed an event that has signalled, the signaller
 750    --  must cleanup. Cleanup consists of freeing the event control block.
 751
 752    procedure Disable_Event
 753       (Flags       : Bit_Array_32;
 754        Event_Value : Unsigned_Longword;
 755        Event_Code  : Unsigned_Longword;
 756        Status      : out Cond_Value_Type);
 757    --  Disable a DEBUG tasking event
 758
 759    function DoAC (S : String) return Address;
 760    --  Convert a string to the address of an internal buffer containing
 761    --  the counted ASCII.
 762
 763    procedure Enable_Event
 764       (Flags       : Bit_Array_32;
 765        Event_Value : Unsigned_Longword;
 766        Event_Code  : Unsigned_Longword;
 767        Status      : out Cond_Value_Type);
 768    --  Enable a requested DEBUG tasking event
 769
 770    procedure Find_Event_By_Code
 771       (Event_Code  : Unsigned_Longword;
 772        Event_Entry : out Unsigned_Longword;
 773        Status      : out Cond_Value_Type);
 774    --  Convert an event code to the address of the event entry
 775
 776    procedure Find_Event_By_Name
 777       (Event_Name  : Unsigned_Longword;
 778        Event_Entry : out Unsigned_Longword;
 779        Status      : out Cond_Value_Type);
 780    --  Find an event entry given the event name
 781
 782    procedure List_Entry_Waiters
 783      (Task_Value      : Task_Id;
 784       Full_Display    : Boolean := False;
 785       Suppress_Header : Boolean := False;
 786       Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access);
 787    --  List information about tasks waiting on an entry
 788
 789    procedure Put (S : String);
 790    --  Display S on standard output
 791
 792    procedure Put_Line (S : String := "");
 793    --  Display S on standard output with an additional line terminator
 794
 795    procedure Show_Event
 796       (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
 797    --  Show what events are available
 798
 799    procedure Show_One_Task
 800      (Task_Value      : Task_Id;
 801       Full_Display    : Boolean := False;
 802       Suppress_Header : Boolean := False;
 803       Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access);
 804    --  Display information about one task
 805
 806    procedure Show_Rendezvous
 807      (Task_Value      : Task_Id;
 808       Ada_State       : AASCIC := Empty_Text;
 809       Full_Display    : Boolean := False;
 810       Suppress_Header : Boolean := False;
 811       Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access);
 812    --  Display information about a task rendezvous
 813
 814    procedure Trace_Output (Message_String : String);
 815    --  Call Put_Output if Trace_on ("VMS")
 816
 817    procedure Write (Fd : Integer; S : String; Count : Integer);
 818
 819    --------------------
 820    -- Announce_Event --
 821    --------------------
 822
 823    procedure Announce_Event
 824       (Event_EVCB    : Unsigned_Longword;
 825        Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
 826    is
 827       EVCB : constant Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB);
 828
 829       Event_Kind : constant Event_Kind_Type :=
 830                      (if EVCB.Sub_Event /= 0
 831                       then Event_Kind_Type (EVCB.Sub_Event)
 832                       else Event_Kind_Type (EVCB.Code));
 833
 834       TI : constant String := "   Task %TASK !UI is ";
 835       --  Announce prefix
 836
 837    begin
 838       Trace_Output ("Announce called");
 839
 840       case Event_Kind is
 841          when Debug_Event_Activating =>
 842             Print_Routine (Print_FAO, Print_Newline,
 843               To_UL (DoAC (TI & "about to begin its activation")),
 844               EVCB.Value);
 845          when Debug_Event_Exception_Terminated =>
 846             Print_Routine (Print_FAO, Print_Newline,
 847               To_UL (DoAC (TI & "terminating because of an exception")),
 848               EVCB.Value);
 849          when Debug_Event_Run =>
 850             Print_Routine (Print_FAO, Print_Newline,
 851               To_UL (DoAC (TI & "about to run")),
 852               EVCB.Value);
 853          when Debug_Event_Abort_Terminated =>
 854             Print_Routine (Print_FAO, Print_Newline,
 855               To_UL (DoAC (TI & "terminating because of abort")),
 856               EVCB.Value);
 857          when Debug_Event_Terminated =>
 858             Print_Routine (Print_FAO, Print_Newline,
 859               To_UL (DoAC (TI & "terminating normally")),
 860               EVCB.Value);
 861          when others => null;
 862       end case;
 863    end Announce_Event;
 864
 865    -------------------
 866    -- Cleanup_Event --
 867    -------------------
 868
 869    procedure Cleanup_Event (Event_EVCB  : Unsigned_Longword) is
 870       EVCB : Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB);
 871    begin
 872       Free (EVCB);
 873    end Cleanup_Event;
 874
 875    ------------------------
 876    -- Continue_All_Tasks --
 877    ------------------------
 878
 879    procedure Continue_All_Tasks is
 880    begin
 881       null; --  VxWorks
 882    end Continue_All_Tasks;
 883
 884    ------------
 885    -- DBGEXT --
 886    ------------
 887
 888    function DBGEXT
 889      (Control_Block : DBGEXT_Control_Block_Access)
 890       return System.Aux_DEC.Unsigned_Word
 891    is
 892       Print_Routine : Print_Routine_Type := Default_Print_Routine'Access;
 893    begin
 894       Trace_Output ("DBGEXT called");
 895
 896       if Control_Block.Print_Routine /= Address_Zero then
 897          Print_Routine := To_Print_Routine_Type (Control_Block.Print_Routine);
 898       end if;
 899
 900       case Control_Block.Function_Code is
 901
 902          --  Convert a task value to a task number.
 903          --  The output results are stored in the CONTROL_BLOCK.
 904
 905          when K_CVT_VALUE_NUM =>
 906             Trace_Output ("DBGEXT param 1 - CVT Value to NUM");
 907             Control_Block.Task_Number :=
 908               Control_Block.Task_Value.Known_Tasks_Index + 1;
 909             Control_Block.Status := K_SUCCESS;
 910             Trace_Output ("Task Number: ");
 911             Trace_Output (Integer'Image (Control_Block.Task_Number));
 912             return SS_NORMAL;
 913
 914          --  Convert a task number to a task value.
 915          --  The output results are stored in the CONTROL_BLOCK.
 916
 917          when K_CVT_NUM_VALUE =>
 918             Trace_Output ("DBGEXT param 2 - CVT NUM to Value");
 919             Trace_Output ("Task Number: ");
 920             Trace_Output (Integer'Image (Control_Block.Task_Number));
 921             Control_Block.Task_Value :=
 922               Known_Tasks (Control_Block.Task_Number - 1);
 923             Control_Block.Status := K_SUCCESS;
 924             Trace_Output ("Task Value: ");
 925             Trace_Output (Unsigned_Longword'Image
 926               (To_UL (Control_Block.Task_Value)));
 927             return SS_NORMAL;
 928
 929          --  Obtain the "next" task after a specified task.
 930          --  ??? To do: If specified check the PRIORITY, STATE, and HOLD
 931          --  fields to restrict the selection of the next task.
 932          --  The output results are stored in the CONTROL_BLOCK.
 933
 934          when K_NEXT_TASK =>
 935             Trace_Output ("DBGEXT param 3 - Next Task");
 936             Trace_Output ("Task Value: ");
 937             Trace_Output (Unsigned_Longword'Image
 938               (To_UL (Control_Block.Task_Value)));
 939
 940             if Control_Block.Task_Value = null then
 941                Control_Block.Task_Value := Known_Tasks (Known_Tasks'First);
 942             else
 943                Control_Block.Task_Value :=
 944                  Known_Tasks (Control_Block.Task_Value.Known_Tasks_Index + 1);
 945             end if;
 946
 947             if Control_Block.Task_Value = null then
 948                Control_Block.Task_Value := Known_Tasks (Known_Tasks'First);
 949             end if;
 950
 951             Control_Block.Status := K_SUCCESS;
 952             return SS_NORMAL;
 953
 954          --  Display the state of a task. The FULL bit is checked to decide if
 955          --  a full or brief task display is desired. The output results are
 956          --  stored in the CONTROL_BLOCK.
 957
 958          when K_SHOW_TASK =>
 959             Trace_Output ("DBGEXT param 4 - Show Task");
 960
 961             if Control_Block.Task_Value = null then
 962                Control_Block.Status := K_TASK_NOT_EXIST;
 963             else
 964                Show_One_Task
 965                  (Control_Block.Task_Value,
 966                   Control_Block.Ada_Flags (V_Full_Display),
 967                   Control_Block.Ada_Flags (V_Suppress_Header),
 968                   Print_Routine);
 969
 970                Control_Block.Status := K_SUCCESS;
 971             end if;
 972
 973             return SS_NORMAL;
 974
 975          --  Enable a requested DEBUG tasking event
 976
 977          when K_ENABLE_EVENT =>
 978             Trace_Output ("DBGEXT param 17 - Enable Event");
 979             Enable_Event
 980               (Control_Block.Flags,
 981                Control_Block.Event_Value_or_Name,
 982                Control_Block.Event_Code_or_EVCB,
 983                Control_Block.Status);
 984
 985             return SS_NORMAL;
 986
 987          --  Disable a DEBUG tasking event
 988
 989          when K_DISABLE_EVENT =>
 990             Trace_Output ("DBGEXT param 18 - Disable Event");
 991             Disable_Event
 992               (Control_Block.Flags,
 993                Control_Block.Event_Value_or_Name,
 994                Control_Block.Event_Code_or_EVCB,
 995                Control_Block.Status);
 996
 997             return SS_NORMAL;
 998
 999          --  Announce the occurence of a DEBUG tasking event
1000
1001          when K_ANNOUNCE_EVENT =>
1002             Trace_Output ("DBGEXT param 19 - Announce Event");
1003             Announce_Event
1004               (Control_Block.Event_Code_or_EVCB,
1005                Print_Routine);
1006
1007             Control_Block.Status := K_SUCCESS;
1008             return SS_NORMAL;
1009
1010          --  After DEBUG has processed an event that has signalled,
1011          --  the signaller must cleanup.
1012          --  Cleanup consists of freeing the event control block.
1013
1014          when K_CLEANUP_EVENT =>
1015             Trace_Output ("DBGEXT param 24 - Cleanup Event");
1016             Cleanup_Event (Control_Block.Event_Code_or_EVCB);
1017
1018             Control_Block.Status := K_SUCCESS;
1019             return SS_NORMAL;
1020
1021          --  Show what events are available
1022
1023          when K_SHOW_EVENT_DEF =>
1024             Trace_Output ("DBGEXT param 25 - Show Event Def");
1025             Show_Event (Print_Routine);
1026
1027             Control_Block.Status := K_SUCCESS;
1028             return SS_NORMAL;
1029
1030          --  Convert an event code to the address of the event entry
1031
1032          when K_FIND_EVENT_BY_CODE =>
1033             Trace_Output ("DBGEXT param 29 - Find Event by Code");
1034             Find_Event_By_Code
1035               (Control_Block.Event_Code_or_EVCB,
1036                Control_Block.Event_Entry,
1037                Control_Block.Status);
1038
1039             return SS_NORMAL;
1040
1041          --  Find an event entry given the event name
1042
1043          when K_FIND_EVENT_BY_NAME =>
1044             Trace_Output ("DBGEXT param 30 - Find Event by Name");
1045             Find_Event_By_Name
1046               (Control_Block.Event_Value_or_Name,
1047                Control_Block.Event_Entry,
1048                Control_Block.Status);
1049             return SS_NORMAL;
1050
1051          --  ??? To do: Implement priority events
1052          --  Get, set or restore a task's priority
1053
1054          when K_GET_PRIORITY or K_SET_PRIORITY or K_RESTORE_PRIORITY =>
1055             Trace_Output ("DBGEXT priority param - Not yet implemented");
1056             Trace_Output (Function_Codes'Image
1057              (Control_Block.Function_Code));
1058             return SS_BADPARAM;
1059
1060          --  ??? To do: Implement show statistics event
1061          --  Display task statistics
1062
1063          when K_SHOW_STAT =>
1064             Trace_Output ("DBGEXT show stat param - Not yet implemented");
1065             Trace_Output (Function_Codes'Image
1066              (Control_Block.Function_Code));
1067             return SS_BADPARAM;
1068
1069          --  ??? To do: Implement get caller event
1070          --  Obtain the caller of a task in a rendezvous. If no rendezvous,
1071          --  null is returned
1072
1073          when K_GET_CALLER =>
1074             Trace_Output ("DBGEXT get caller param - Not yet implemented");
1075             Trace_Output (Function_Codes'Image
1076              (Control_Block.Function_Code));
1077             return SS_BADPARAM;
1078
1079          --  ??? To do: Implement set terminate event
1080          --  Terminate a task
1081
1082          when K_SET_ABORT =>
1083             Trace_Output ("DBGEXT set terminate param - Not yet implemented");
1084             Trace_Output (Function_Codes'Image
1085              (Control_Block.Function_Code));
1086             return SS_BADPARAM;
1087
1088          --  ??? To do: Implement show deadlock event
1089          --  Detect a deadlock
1090
1091          when K_SHOW_DEADLOCK =>
1092             Trace_Output ("DBGEXT show deadlock param - Not yet implemented");
1093             Trace_Output (Function_Codes'Image
1094              (Control_Block.Function_Code));
1095             return SS_BADPARAM;
1096
1097          when others =>
1098             Trace_Output ("DBGEXT bad param: ");
1099             Trace_Output (Function_Codes'Image
1100              (Control_Block.Function_Code));
1101             return SS_BADPARAM;
1102
1103       end case;
1104    end DBGEXT;
1105
1106    ---------------------------
1107    -- Default_Print_Routine --
1108    ---------------------------
1109
1110    procedure Default_Print_Routine
1111      (Print_Function    : Print_Functions;
1112       Print_Subfunction : Print_Functions;
1113       P1                : Unsigned_Longword := 0;
1114       P2                : Unsigned_Longword := 0;
1115       P3                : Unsigned_Longword := 0;
1116       P4                : Unsigned_Longword := 0;
1117       P5                : Unsigned_Longword := 0;
1118       P6                : Unsigned_Longword := 0)
1119    is
1120       Status    : Cond_Value_Type;
1121       Linlen    : Unsigned_Word;
1122       Item_List : Unsigned_Longword_Array (1 .. 17) :=
1123         (1 .. 17 => 0);
1124    begin
1125
1126       case Print_Function is
1127          when Print_Control | Print_String =>
1128             null;
1129
1130          --  Formatted Ascii Output
1131
1132          when Print_FAO =>
1133             Item_List (1) := P2;
1134             Item_List (2) := P3;
1135             Item_List (3) := P4;
1136             Item_List (4) := P5;
1137             Item_List (5) := P6;
1138             FAOL
1139               (Status,
1140                To_AASCIC (P1).Text,
1141                Linlen,
1142                Print_Routine_Linbuf
1143                  (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz),
1144                Item_List);
1145
1146             Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen);
1147
1148          --  Symbolic output
1149
1150          when Print_Symbol =>
1151             Item_List (1) := P1;
1152             FAOL
1153               (Status,
1154                "!XI",
1155                Linlen,
1156                Print_Routine_Linbuf
1157                  (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz),
1158                Item_List);
1159
1160             Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen);
1161
1162          when others =>
1163             null;
1164       end case;
1165
1166       case Print_Subfunction is
1167
1168          --  Output buffer with a terminating newline
1169
1170          when Print_Newline =>
1171             Put_Output (Status,
1172               Print_Routine_Linbuf (1 .. Print_Routine_Bufcnt));
1173             Print_Routine_Bufcnt := 0;
1174
1175          --  Buffer the output
1176
1177          when No_Print =>
1178             null;
1179
1180          when others =>
1181             null;
1182       end case;
1183
1184    end Default_Print_Routine;
1185
1186    -------------------
1187    -- Disable_Event --
1188    -------------------
1189
1190    procedure Disable_Event
1191       (Flags       : Bit_Array_32;
1192        Event_Value : Unsigned_Longword;
1193        Event_Code  : Unsigned_Longword;
1194        Status      : out Cond_Value_Type)
1195    is
1196       Task_Value : Task_Id;
1197       Task_Index : constant Integer := Integer (Event_Value) - 1;
1198    begin
1199
1200       Events_Enabled_Count := Events_Enabled_Count - 1;
1201
1202       if Flags (V_EVNT_ALL) then
1203          Global_Task_Debug_Events (Integer (Event_Code)) := False;
1204          Status := K_SUCCESS;
1205       else
1206          if Task_Index in Known_Tasks'Range then
1207             Task_Value := Known_Tasks (Task_Index);
1208             if Task_Value /= null then
1209                Task_Value.Common.Debug_Events (Integer (Event_Code)) := False;
1210                Status := K_SUCCESS;
1211             else
1212                Status := K_TASK_NOT_EXIST;
1213             end if;
1214          else
1215             Status := K_TASK_NOT_EXIST;
1216          end if;
1217       end if;
1218
1219       --  Keep count of events for efficiency
1220
1221       if Events_Enabled_Count <= 0 then
1222          Events_Enabled_Count := 0;
1223          Global_Task_Debug_Event_Set := False;
1224       end if;
1225
1226    end Disable_Event;
1227
1228    ----------
1229    -- DoAC --
1230    ----------
1231
1232    function DoAC (S : String) return Address is
1233    begin
1234       AC_Buffer.Count := S'Length;
1235       AC_Buffer.Text (1 .. AC_Buffer.Count) := S;
1236       return AC_Buffer'Address;
1237    end DoAC;
1238
1239    ------------------
1240    -- Enable_Event --
1241    ------------------
1242
1243    procedure Enable_Event
1244       (Flags       : Bit_Array_32;
1245        Event_Value : Unsigned_Longword;
1246        Event_Code  : Unsigned_Longword;
1247        Status      : out Cond_Value_Type)
1248    is
1249       Task_Value : Task_Id;
1250       Task_Index : constant Integer := Integer (Event_Value) - 1;
1251    begin
1252
1253       --  At least one event enabled, any and all events will cause a
1254       --  condition to be raised and checked. Major tasking slowdown!
1255
1256       Global_Task_Debug_Event_Set := True;
1257       Events_Enabled_Count := Events_Enabled_Count + 1;
1258
1259       if Flags (V_EVNT_ALL) then
1260          Global_Task_Debug_Events (Integer (Event_Code)) := True;
1261          Status := K_SUCCESS;
1262       else
1263          if Task_Index in Known_Tasks'Range then
1264             Task_Value := Known_Tasks (Task_Index);
1265             if Task_Value /= null then
1266                Task_Value.Common.Debug_Events (Integer (Event_Code)) := True;
1267                Status := K_SUCCESS;
1268             else
1269                Status := K_TASK_NOT_EXIST;
1270             end if;
1271          else
1272             Status := K_TASK_NOT_EXIST;
1273          end if;
1274       end if;
1275
1276    end Enable_Event;
1277
1278    ------------------------
1279    -- Find_Event_By_Code --
1280    ------------------------
1281
1282    procedure Find_Event_By_Code
1283       (Event_Code  : Unsigned_Longword;
1284        Event_Entry : out Unsigned_Longword;
1285        Status      : out Cond_Value_Type)
1286    is
1287       K_SUCCESS        : constant := 1;
1288       K_NO_SUCH_EVENT  : constant := 9;
1289
1290    begin
1291       Trace_Output ("Looking for Event: ");
1292       Trace_Output (Unsigned_Longword'Image (Event_Code));
1293
1294       for I in Event_Kind_Type'Range loop
1295          if Event_Code = Unsigned_Longword (Event_Directory (I).Code) then
1296             Event_Entry := To_UL (Event_Directory (I)'Address);
1297             Trace_Output ("Found Event # ");
1298             Trace_Output (Integer'Image (I));
1299             Status := K_SUCCESS;
1300             return;
1301          end if;
1302       end loop;
1303
1304       Status := K_NO_SUCH_EVENT;
1305    end Find_Event_By_Code;
1306
1307    ------------------------
1308    -- Find_Event_By_Name --
1309    ------------------------
1310
1311    procedure Find_Event_By_Name
1312       (Event_Name  : Unsigned_Longword;
1313        Event_Entry : out Unsigned_Longword;
1314        Status      : out Cond_Value_Type)
1315    is
1316       K_SUCCESS        : constant := 1;
1317       K_NO_SUCH_EVENT  : constant := 9;
1318
1319       Event_Name_Cstr : constant ASCIC := To_AASCIC (Event_Name).all;
1320    begin
1321       Trace_Output ("Looking for Event: ");
1322       Trace_Output (Event_Name_Cstr.Text);
1323
1324       for I in Event_Kind_Type'Range loop
1325          if Event_Name_Cstr.Count >= Event_Directory (I).Minchr
1326             and then Event_Name_Cstr.Count <= Event_Directory (I).Name.Count
1327             and then Event_Name_Cstr.Text (1 .. Event_Directory (I).Minchr) =
1328                 Event_Directory (I).Name.Text (1 .. Event_Directory (I).Minchr)
1329          then
1330             Event_Entry := To_UL (Event_Directory (I)'Address);
1331             Trace_Output ("Found Event # ");
1332             Trace_Output (Integer'Image (I));
1333             Status := K_SUCCESS;
1334             return;
1335          end if;
1336       end loop;
1337
1338       Status := K_NO_SUCH_EVENT;
1339    end Find_Event_By_Name;
1340
1341    --------------------
1342    -- Get_User_State --
1343    --------------------
1344
1345    function Get_User_State return Long_Integer is
1346    begin
1347       return STPO.Self.User_State;
1348    end Get_User_State;
1349
1350    ------------------------
1351    -- List_Entry_Waiters --
1352    ------------------------
1353
1354    procedure List_Entry_Waiters
1355      (Task_Value      : Task_Id;
1356       Full_Display    : Boolean := False;
1357       Suppress_Header : Boolean := False;
1358       Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access)
1359    is
1360       pragma Unreferenced (Suppress_Header);
1361
1362       Entry_Call : Entry_Call_Link;
1363       Have_Some  : Boolean := False;
1364    begin
1365       if not Full_Display then
1366          return;
1367       end if;
1368
1369       if Task_Value.Entry_Queues'Length > 0 then
1370          Print_Routine (Print_FAO, Print_Newline,
1371            To_UL (DoAC ("        Waiting entry callers:")));
1372       end if;
1373       for I in Task_Value.Entry_Queues'Range loop
1374          Entry_Call := Task_Value.Entry_Queues (I).Head;
1375          if Entry_Call /= null then
1376             Have_Some := True;
1377
1378             Print_Routine (Print_FAO, Print_Newline,
1379               To_UL (DoAC ("          Waiters for entry !UI:")),
1380               To_UL (I));
1381
1382             loop
1383                declare
1384                   Task_Image : ASCIC :=
1385                    (Entry_Call.Self.Common.Task_Image_Len,
1386                     Entry_Call.Self.Common.Task_Image
1387                      (1 .. Entry_Call.Self.Common.Task_Image_Len));
1388                begin
1389                   Print_Routine (Print_FAO, Print_Newline,
1390                     To_UL (DoAC ("              %TASK !UI, type: !AC")),
1391                     To_UL (Entry_Call.Self.Known_Tasks_Index + 1),
1392                     To_UL (Task_Image'Address));
1393                   if Entry_Call = Task_Value.Entry_Queues (I).Tail then
1394                      exit;
1395                   end if;
1396                   Entry_Call := Entry_Call.Next;
1397                end;
1398             end loop;
1399          end if;
1400       end loop;
1401       if not Have_Some then
1402          Print_Routine (Print_FAO, Print_Newline,
1403            To_UL (DoAC ("          none.")));
1404       end if;
1405    end List_Entry_Waiters;
1406
1407    ----------------
1408    -- List_Tasks --
1409    ----------------
1410
1411    procedure List_Tasks is
1412       C : Task_Id;
1413    begin
1414       C := All_Tasks_List;
1415
1416       while C /= null loop
1417          Print_Task_Info (C);
1418          C := C.Common.All_Tasks_Link;
1419       end loop;
1420    end List_Tasks;
1421
1422    ------------------------
1423    -- Print_Current_Task --
1424    ------------------------
1425
1426    procedure Print_Current_Task is
1427    begin
1428       Print_Task_Info (STPO.Self);
1429    end Print_Current_Task;
1430
1431    ---------------------
1432    -- Print_Task_Info --
1433    ---------------------
1434
1435    procedure Print_Task_Info (T : Task_Id) is
1436       Entry_Call : Entry_Call_Link;
1437       Parent     : Task_Id;
1438
1439    begin
1440       if T = null then
1441          Put_Line ("null task");
1442          return;
1443       end if;
1444
1445       Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " &
1446            Task_States'Image (T.Common.State));
1447
1448       Parent := T.Common.Parent;
1449
1450       if Parent = null then
1451          Put (", parent: <none>");
1452       else
1453          Put (", parent: " &
1454               Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len));
1455       end if;
1456
1457       Put (", prio:" & T.Common.Current_Priority'Img);
1458
1459       if not T.Callable then
1460          Put (", not callable");
1461       end if;
1462
1463       if T.Aborting then
1464          Put (", aborting");
1465       end if;
1466
1467       if T.Deferral_Level /= 0 then
1468          Put (", abort deferred");
1469       end if;
1470
1471       if T.Common.Call /= null then
1472          Entry_Call := T.Common.Call;
1473          Put (", serving:");
1474
1475          while Entry_Call /= null loop
1476             Put (To_Integer (Entry_Call.Self)'Img);
1477             Entry_Call := Entry_Call.Acceptor_Prev_Call;
1478          end loop;
1479       end if;
1480
1481       if T.Open_Accepts /= null then
1482          Put (", accepting:");
1483
1484          for J in T.Open_Accepts'Range loop
1485             Put (T.Open_Accepts (J).S'Img);
1486          end loop;
1487
1488          if T.Terminate_Alternative then
1489             Put (" or terminate");
1490          end if;
1491       end if;
1492
1493       if T.User_State /= 0 then
1494          Put (", state:" & T.User_State'Img);
1495       end if;
1496
1497       Put_Line;
1498    end Print_Task_Info;
1499
1500    ---------
1501    -- Put --
1502    ---------
1503
1504    procedure Put (S : String) is
1505    begin
1506       Write (2, S, S'Length);
1507    end Put;
1508
1509    --------------
1510    -- Put_Line --
1511    --------------
1512
1513    procedure Put_Line (S : String := "") is
1514    begin
1515       Write (2, S & ASCII.LF, S'Length + 1);
1516    end Put_Line;
1517
1518    ----------------------
1519    -- Resume_All_Tasks --
1520    ----------------------
1521
1522    procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
1523       pragma Unreferenced (Thread_Self);
1524    begin
1525       null; --  VxWorks
1526    end Resume_All_Tasks;
1527
1528    ---------------
1529    -- Set_Trace --
1530    ---------------
1531
1532    procedure Set_Trace (Flag  : Character; Value : Boolean := True) is
1533    begin
1534       Trace_On (Flag) := Value;
1535    end Set_Trace;
1536
1537    --------------------
1538    -- Set_User_State --
1539    --------------------
1540
1541    procedure Set_User_State (Value : Long_Integer) is
1542    begin
1543       STPO.Self.User_State := Value;
1544    end Set_User_State;
1545
1546    ----------------
1547    -- Show_Event --
1548    ----------------
1549
1550    procedure Show_Event
1551       (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
1552    is
1553    begin
1554       for I in Event_Def_Help'Range loop
1555          Print_Routine (Print_FAO, Print_Newline, To_UL (Event_Def_Help (I)));
1556       end loop;
1557
1558       for I in Event_Kind_Type'Range loop
1559          Print_Routine (Print_FAO, Print_Newline,
1560            To_UL (Event_Directory
1561                    (Global_Event_Display_Order (I)).Name'Address));
1562          Print_Routine (Print_FAO, Print_Newline,
1563            To_UL (Event_Directory (Global_Event_Display_Order (I)).Help));
1564       end loop;
1565    end Show_Event;
1566
1567    --------------------
1568    -- Show_One_Task --
1569    --------------------
1570
1571    procedure Show_One_Task
1572      (Task_Value      : Task_Id;
1573       Full_Display    : Boolean := False;
1574       Suppress_Header : Boolean := False;
1575       Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access)
1576    is
1577       Task_SP            : System.Address := Address_Zero;
1578       Stack_Base         : System.Address := Address_Zero;
1579       Stack_Top          : System.Address := Address_Zero;
1580       TCB_Size           : Unsigned_Longword := 0;
1581       CMA_TCB_Size       : Unsigned_Longword := 0;
1582       Stack_Guard_Size   : Unsigned_Longword := 0;
1583       Total_Task_Storage : Unsigned_Longword := 0;
1584       Stack_In_Use       : Unsigned_Longword := 0;
1585       Reserved_Size      : Unsigned_Longword := 0;
1586       Hold_Flag          : Unsigned_Longword := 0;
1587       Sched_State        : Unsigned_Longword := 0;
1588       User_Prio          : Unsigned_Longword := 0;
1589       Stack_Size         : Unsigned_Longword := 0;
1590       Run_State          : Boolean := False;
1591       Rea_State          : Boolean := False;
1592       Sus_State          : Boolean := False;
1593       Ter_State          : Boolean := False;
1594
1595       Current_Flag : AASCIC := NoStar;
1596       Hold_String  : AASCIC := NoHold;
1597       Ada_State    : AASCIC := Ada_State_Invalid_State;
1598       Debug_State  : AASCIC := Debug_State_Emp;
1599
1600       Ada_State_Len   : constant Unsigned_Longword := 17;
1601       Debug_State_Len : constant Unsigned_Longword := 5;
1602
1603       Entry_Call : Entry_Call_Record;
1604
1605    begin
1606
1607       --  Initialize local task info variables
1608
1609       Task_SP := Address_Zero;
1610       Stack_Base := Address_Zero;
1611       Stack_Top := Address_Zero;
1612       CMA_TCB_Size := 0;
1613       Stack_Guard_Size := 0;
1614       Reserved_Size := 0;
1615       Hold_Flag := 0;
1616       Sched_State := 0;
1617       TCB_Size := Unsigned_Longword (Task_Id'Size);
1618
1619       if not Suppress_Header or else Full_Display then
1620          Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
1621          Print_Routine (Print_FAO, Print_Newline, To_UL (Header));
1622       end if;
1623
1624       Trace_Output ("Show_One_Task Task Value: ");
1625       Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value)));
1626
1627       --  Callback to DEBUG to get some task info
1628
1629       if Task_Value.Common.State /= Terminated then
1630          Debug_Get
1631            (STPO.Get_Thread_Id (Task_Value),
1632             CMA_C_DEBGET_STACKPTR,
1633             Task_SP,
1634             8);
1635
1636          Debug_Get
1637            (STPO.Get_Thread_Id (Task_Value),
1638             CMA_C_DEBGET_TCB_SIZE,
1639             CMA_TCB_Size,
1640             4);
1641
1642          Debug_Get
1643            (STPO.Get_Thread_Id (Task_Value),
1644             CMA_C_DEBGET_GUARDSIZE,
1645             Stack_Guard_Size,
1646             4);
1647
1648          Debug_Get
1649            (STPO.Get_Thread_Id (Task_Value),
1650             CMA_C_DEBGET_YELLOWSIZE,
1651             Reserved_Size,
1652             4);
1653
1654          Debug_Get
1655            (STPO.Get_Thread_Id (Task_Value),
1656             CMA_C_DEBGET_STACK_BASE,
1657             Stack_Base,
1658             8);
1659
1660          Debug_Get
1661            (STPO.Get_Thread_Id (Task_Value),
1662             CMA_C_DEBGET_STACK_TOP,
1663             Stack_Top,
1664             8);
1665
1666          Stack_Size := Unsigned_Longword (Stack_Base - Stack_Top)
1667            - Reserved_Size - Stack_Guard_Size;
1668          Stack_In_Use := Unsigned_Longword (Stack_Base - Task_SP) + 4;
1669          Total_Task_Storage := TCB_Size + Stack_Size + Stack_Guard_Size
1670            + Reserved_Size + CMA_TCB_Size;
1671
1672          Debug_Get
1673            (STPO.Get_Thread_Id (Task_Value),
1674             CMA_C_DEBGET_IS_HELD,
1675             Hold_Flag,
1676             4);
1677
1678          Hold_String := (if Hold_Flag /= 0 then Hold else NoHold);
1679
1680          Debug_Get
1681            (STPO.Get_Thread_Id (Task_Value),
1682             CMA_C_DEBGET_SCHED_STATE,
1683             Sched_State,
1684             4);
1685       end if;
1686
1687       Run_State := False;
1688       Rea_State := False;
1689       Sus_State := Task_Value.Common.State = Unactivated;
1690       Ter_State := Task_Value.Common.State = Terminated;
1691
1692       if not Ter_State then
1693          Run_State := Sched_State = 0;
1694          Rea_State := Sched_State = 1;
1695          Sus_State := Sched_State /= 0 and Sched_State /= 1;
1696       end if;
1697
1698       --  Set the debug state
1699
1700       if Run_State then
1701          Debug_State := Debug_State_Run;
1702       elsif Rea_State then
1703          Debug_State := Debug_State_Rea;
1704       elsif Sus_State then
1705          Debug_State := Debug_State_Sus;
1706       elsif Ter_State then
1707          Debug_State := Debug_State_Ter;
1708       end if;
1709
1710       Trace_Output ("Before case State: ");
1711       Trace_Output (Task_States'Image (Task_Value.Common.State));
1712
1713       --  Set the Ada state
1714
1715       case Task_Value.Common.State is
1716          when Unactivated =>
1717             Ada_State := Ada_State_Not_Yet_Activated;
1718
1719          when Activating =>
1720             Ada_State := Ada_State_Activating;
1721
1722          when Runnable =>
1723             Ada_State := Ada_State_Runnable;
1724
1725          when Terminated =>
1726             Ada_State := Ada_State_Terminated;
1727
1728          when Activator_Sleep =>
1729             Ada_State := Ada_State_Activating_Tasks;
1730
1731          when Acceptor_Sleep =>
1732             Ada_State := Ada_State_Accept;
1733
1734          when Acceptor_Delay_Sleep =>
1735             Ada_State := Ada_State_Select_or_Delay;
1736
1737          when Entry_Caller_Sleep =>
1738             Entry_Call :=
1739               Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level);
1740
1741             case Entry_Call.Mode is
1742                when Simple_Call =>
1743                   Ada_State := Ada_State_Entry_Call;
1744                when Conditional_Call =>
1745                   Ada_State := Ada_State_Cond_Entry_Call;
1746                when Timed_Call =>
1747                   Ada_State := Ada_State_Timed_Entry_Call;
1748                when Asynchronous_Call =>
1749                   Ada_State := Ada_State_Async_Entry_Call;
1750             end case;
1751
1752          when Async_Select_Sleep =>
1753             Ada_State := Ada_State_Select_or_Abort;
1754
1755          when Delay_Sleep =>
1756             Ada_State := Ada_State_Delay;
1757
1758          when Master_Completion_Sleep =>
1759             Ada_State := Ada_State_Completed;
1760
1761          when Master_Phase_2_Sleep =>
1762             Ada_State := Ada_State_Completed;
1763
1764          when Interrupt_Server_Idle_Sleep |
1765               Interrupt_Server_Blocked_Interrupt_Sleep |
1766               Timer_Server_Sleep |
1767               Interrupt_Server_Blocked_On_Event_Flag =>
1768             Ada_State := Ada_State_Server;
1769
1770          when AST_Server_Sleep =>
1771             Ada_State := Ada_State_IO_or_AST;
1772
1773          when Asynchronous_Hold =>
1774             Ada_State := Ada_State_Async_Hold;
1775
1776       end case;
1777
1778       if Task_Value.Terminate_Alternative then
1779          Ada_State := Ada_State_Select_or_Term;
1780       end if;
1781
1782       if Task_Value.Aborting then
1783          Ada_State := Ada_State_Aborting;
1784       end if;
1785
1786       User_Prio := To_UL (Task_Value.Common.Current_Priority);
1787       Trace_Output ("After user_prio");
1788
1789       --  Flag the current task
1790
1791       Current_Flag := (if Task_Value = Self then Star else NoStar);
1792
1793       --  Show task info
1794
1795       Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!AC%TASK !5<!UI!>")),
1796         To_UL (Current_Flag), To_UL (Task_Value.Known_Tasks_Index + 1));
1797
1798       Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!2UB")), User_Prio);
1799
1800       Print_Routine (Print_FAO, No_Print, To_UL (DoAC (" !AC !5AD !17AD ")),
1801         To_UL (Hold_String), Debug_State_Len, To_UL (Debug_State),
1802         Ada_State_Len, To_UL (Ada_State));
1803
1804 --      Print_Routine (Print_Symbol, Print_Newline,
1805 --         Fetch (To_Addr (Task_Value.Common.Task_Entry_Point)));
1806
1807       Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
1808
1809       --  If /full qualfier passed, show detailed info
1810
1811       if Full_Display then
1812          Show_Rendezvous (Task_Value, Ada_State, Full_Display,
1813            Suppress_Header, Print_Routine);
1814
1815          List_Entry_Waiters (Task_Value, Full_Display,
1816            Suppress_Header, Print_Routine);
1817
1818          Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
1819
1820          declare
1821             Task_Image : ASCIC := (Task_Value.Common.Task_Image_Len,
1822               Task_Value.Common.Task_Image
1823                (1 .. Task_Value.Common.Task_Image_Len));
1824          begin
1825             Print_Routine (Print_FAO, Print_Newline,
1826               To_UL (DoAC ("        Task type:      !AC")),
1827               To_UL (Task_Image'Address));
1828          end;
1829
1830          --  How to find Creation_PC ???
1831 --         Print_Routine (Print_FAO, No_Print,
1832 --           To_UL (DoAC ("        Created at PC:  ")),
1833 --         Print_Routine (Print_FAO, Print_Newline, Creation_PC);
1834
1835          if Task_Value.Common.Parent /= null then
1836             Print_Routine (Print_FAO, Print_Newline,
1837               To_UL (DoAC ("        Parent task:    %TASK !UI")),
1838               To_UL (Task_Value.Common.Parent.Known_Tasks_Index + 1));
1839          else
1840             Print_Routine (Print_FAO, Print_Newline,
1841              To_UL (DoAC ("        Parent task:    none")));
1842          end if;
1843
1844 --         Print_Routine (Print_FAO, No_Print,
1845 --           To_UL (DoAC ("        Start PC:       ")));
1846 --         Print_Routine (Print_Symbol, Print_Newline,
1847 --            Fetch (To_Addr (Task_Value.Common.Task_Entry_Point)));
1848
1849          Print_Routine (Print_FAO, Print_Newline,
1850           To_UL (DoAC (
1851            "        Task control block:             Stack storage (bytes):")));
1852
1853          Print_Routine (Print_FAO, Print_Newline,
1854           To_UL (DoAC (
1855            "          Task value:   !10<!UI!>        RESERVED_BYTES:  !10UI")),
1856           To_UL (Task_Value), Reserved_Size);
1857
1858          Print_Routine (Print_FAO, Print_Newline,
1859           To_UL (DoAC (
1860            "          Entries:      !10<!UI!>        TOP_GUARD_SIZE:  !10UI")),
1861           To_UL (Task_Value.Entry_Num), Stack_Guard_Size);
1862
1863          Print_Routine (Print_FAO, Print_Newline,
1864           To_UL (DoAC (
1865            "          Size:         !10<!UI!>        STORAGE_SIZE:    !10UI")),
1866           TCB_Size + CMA_TCB_Size, Stack_Size);
1867
1868          Print_Routine (Print_FAO, Print_Newline,
1869           To_UL (DoAC (
1870            "        Stack addresses:                 Bytes in use:    !10UI")),
1871           Stack_In_Use);
1872
1873          Print_Routine (Print_FAO, Print_Newline,
1874           To_UL (DoAC ("          Top address:  !10<!XI!>")),
1875           To_UL (Stack_Top));
1876
1877          Print_Routine (Print_FAO, Print_Newline,
1878           To_UL (DoAC (
1879            "          Base address: !10<!XI!>      Total storage:     !10UI")),
1880           To_UL (Stack_Base), Total_Task_Storage);
1881       end if;
1882
1883    end Show_One_Task;
1884
1885    ---------------------
1886    -- Show_Rendezvous --
1887    ---------------------
1888
1889    procedure Show_Rendezvous
1890      (Task_Value      : Task_Id;
1891       Ada_State       : AASCIC := Empty_Text;
1892       Full_Display    : Boolean := False;
1893       Suppress_Header : Boolean := False;
1894       Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access)
1895    is
1896       pragma Unreferenced (Ada_State);
1897       pragma Unreferenced (Suppress_Header);
1898
1899       Temp_Entry  : Entry_Index;
1900       Entry_Call  : Entry_Call_Record;
1901       Called_Task : Task_Id;
1902       AWR         : constant String := "        Awaiting rendezvous at: ";
1903       --  Common prefix
1904
1905       procedure Print_Accepts;
1906       --  Display information about task rendezvous accepts
1907
1908       procedure Print_Accepts is
1909       begin
1910          if Task_Value.Open_Accepts /= null then
1911             for I in Task_Value.Open_Accepts'Range loop
1912                Temp_Entry := Entry_Index (Task_Value.Open_Accepts (I).S);
1913                declare
1914                   Entry_Name_Image : ASCIC :=
1915                     (Task_Value.Entry_Names (Temp_Entry).all'Length,
1916                      Task_Value.Entry_Names (Temp_Entry).all);
1917                begin
1918                   Trace_Output ("Accept at: " & Entry_Name_Image.Text);
1919                   Print_Routine (Print_FAO, Print_Newline,
1920                     To_UL (DoAC ("             accept at: !AC")),
1921                     To_UL (Entry_Name_Image'Address));
1922                end;
1923             end loop;
1924          end if;
1925       end Print_Accepts;
1926    begin
1927       if not Full_Display then
1928          return;
1929       end if;
1930
1931       Trace_Output ("Show_Rendezvous Task Value: ");
1932       Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value)));
1933
1934       if Task_Value.Common.State = Acceptor_Sleep and then
1935          not Task_Value.Terminate_Alternative
1936       then
1937          if Task_Value.Open_Accepts /= null then
1938             Temp_Entry := Entry_Index (Task_Value.Open_Accepts
1939               (Task_Value.Open_Accepts'First).S);
1940             declare
1941                Entry_Name_Image : ASCIC :=
1942                  (Task_Value.Entry_Names (Temp_Entry).all'Length,
1943                   Task_Value.Entry_Names (Temp_Entry).all);
1944             begin
1945                Trace_Output (AWR & "accept " & Entry_Name_Image.Text);
1946                Print_Routine (Print_FAO, Print_Newline,
1947                  To_UL (DoAC (AWR & "accept !AC")),
1948                  To_UL (Entry_Name_Image'Address));
1949             end;
1950
1951          else
1952             Print_Routine (Print_FAO, Print_Newline,
1953               To_UL (DoAC ("        entry name unavailable")));
1954          end if;
1955       else
1956          case Task_Value.Common.State is
1957             when Acceptor_Sleep =>
1958                Print_Routine (Print_FAO, Print_Newline,
1959                  To_UL (DoAC (AWR & "select with terminate.")));
1960                Print_Accepts;
1961
1962             when Async_Select_Sleep =>
1963                Print_Routine (Print_FAO, Print_Newline,
1964                  To_UL (DoAC (AWR & "select.")));
1965                Print_Accepts;
1966
1967             when Acceptor_Delay_Sleep =>
1968                Print_Routine (Print_FAO, Print_Newline,
1969                  To_UL (DoAC (AWR & "select with delay.")));
1970                Print_Accepts;
1971
1972             when Entry_Caller_Sleep =>
1973                Entry_Call :=
1974                  Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level);
1975
1976                case Entry_Call.Mode is
1977                   when Simple_Call =>
1978                      Print_Routine (Print_FAO, Print_Newline,
1979                        To_UL (DoAC (AWR & "entry call")));
1980                   when Conditional_Call =>
1981                      Print_Routine (Print_FAO, Print_Newline,
1982                        To_UL (DoAC (AWR & "entry call with else")));
1983                   when Timed_Call =>
1984                      Print_Routine (Print_FAO, Print_Newline,
1985                        To_UL (DoAC (AWR & "entry call with delay")));
1986                   when Asynchronous_Call =>
1987                      Print_Routine (Print_FAO, Print_Newline,
1988                         To_UL (DoAC (AWR & "entry call with abort")));
1989                end case;
1990                Called_Task := Entry_Call.Called_Task;
1991                declare
1992                   Task_Image : ASCIC := (Called_Task.Common.Task_Image_Len,
1993                     Called_Task.Common.Task_Image
1994                      (1 .. Called_Task.Common.Task_Image_Len));
1995                   Entry_Name_Image : ASCIC :=
1996                     (Called_Task.Entry_Names (Entry_Call.E).all'Length,
1997                      Called_Task.Entry_Names (Entry_Call.E).all);
1998                begin
1999                   Print_Routine (Print_FAO, Print_Newline,
2000                     To_UL (DoAC
2001                      ("        for entry !AC in %TASK !UI type !AC")),
2002                     To_UL (Entry_Name_Image'Address),
2003                     To_UL (Called_Task.Known_Tasks_Index),
2004                     To_UL (Task_Image'Address));
2005                end;
2006
2007             when others =>
2008                return;
2009          end case;
2010       end if;
2011
2012    end Show_Rendezvous;
2013
2014    ------------------------
2015    -- Signal_Debug_Event --
2016    ------------------------
2017
2018    procedure Signal_Debug_Event
2019     (Event_Kind : Event_Kind_Type; Task_Value : Task_Id)
2020    is
2021       Do_Signal : Boolean;
2022       EVCB      : Ada_Event_Control_Block_Access;
2023
2024       EVCB_Sent    : constant := 16#9B#;
2025       Ada_Facility : constant := 49;
2026       SS_DBGEVENT  : constant := 1729;
2027    begin
2028       Do_Signal := Global_Task_Debug_Events (Event_Kind);
2029
2030       if not Do_Signal then
2031          if Task_Value /= null then
2032             Do_Signal := Do_Signal
2033               or else Task_Value.Common.Debug_Events (Event_Kind);
2034          end if;
2035       end if;
2036
2037       if Do_Signal then
2038          --  Build an a tasking event control block and signal DEBUG
2039
2040          EVCB := new Ada_Event_Control_Block_Type;
2041          EVCB.Code := Unsigned_Word (Event_Kind);
2042          EVCB.Sentinal := EVCB_Sent;
2043          EVCB.Facility := Ada_Facility;
2044
2045          if Task_Value /= null then
2046             EVCB.Value := Unsigned_Longword (Task_Value.Known_Tasks_Index + 1);
2047          else
2048             EVCB.Value := 0;
2049          end if;
2050
2051          EVCB.Sub_Event := 0;
2052          EVCB.P1 := 0;
2053          EVCB.Sigargs := 0;
2054          EVCB.Flags := 0;
2055          EVCB.Unused1 := 0;
2056          EVCB.Unused2 := 0;
2057
2058          Signal (SS_DBGEVENT, 1, To_UL (EVCB));
2059       end if;
2060    end Signal_Debug_Event;
2061
2062    --------------------
2063    -- Stop_All_Tasks --
2064    --------------------
2065
2066    procedure Stop_All_Tasks is
2067    begin
2068       null; --  VxWorks
2069    end Stop_All_Tasks;
2070
2071    ----------------------------
2072    -- Stop_All_Tasks_Handler --
2073    ----------------------------
2074
2075    procedure Stop_All_Tasks_Handler is
2076    begin
2077       null; --  VxWorks
2078    end Stop_All_Tasks_Handler;
2079
2080    -----------------------
2081    -- Suspend_All_Tasks --
2082    -----------------------
2083
2084    procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
2085       pragma Unreferenced (Thread_Self);
2086    begin
2087       null; --  VxWorks
2088    end Suspend_All_Tasks;
2089
2090    ------------------------
2091    -- Task_Creation_Hook --
2092    ------------------------
2093
2094    procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
2095       pragma Unreferenced (Thread);
2096    begin
2097       null; --  VxWorks
2098    end Task_Creation_Hook;
2099
2100    ---------------------------
2101    -- Task_Termination_Hook --
2102    ---------------------------
2103
2104    procedure Task_Termination_Hook is
2105    begin
2106       null; --  VxWorks
2107    end Task_Termination_Hook;
2108
2109    -----------
2110    -- Trace --
2111    -----------
2112
2113    procedure Trace
2114      (Self_Id  : Task_Id;
2115       Msg      : String;
2116       Flag     : Character;
2117       Other_Id : Task_Id := null)
2118    is
2119    begin
2120       if Trace_On (Flag) then
2121          Put (To_Integer (Self_Id)'Img &
2122               ':' & Flag & ':' &
2123               Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) &
2124               ':');
2125
2126          if Other_Id /= null then
2127             Put (To_Integer (Other_Id)'Img & ':');
2128          end if;
2129
2130          Put_Line (Msg);
2131       end if;
2132    end Trace;
2133
2134    ------------------
2135    -- Trace_Output --
2136    ------------------
2137
2138    procedure Trace_Output (Message_String : String) is
2139    begin
2140       if Trace_On ('V') and Trace_On ('M') and Trace_On ('S') then
2141          Put_Output (Message_String);
2142       end if;
2143    end Trace_Output;
2144
2145    -----------
2146    -- Write --
2147    -----------
2148
2149    procedure Write (Fd : Integer; S : String; Count : Integer) is
2150       Discard : System.CRTL.ssize_t;
2151       pragma Unreferenced (Discard);
2152    begin
2153       Discard := System.CRTL.write (Fd, S (S'First)'Address,
2154                                     System.CRTL.size_t (Count));
2155       --  Is it really right to ignore write errors here ???
2156    end Write;
2157
2158 end System.Tasking.Debug;