URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tasdeb-vms.adb] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
--                                                                          --
--                  S Y S T E M . T A S K I N G . D E B U G                 --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--          Copyright (C) 2008-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
--                                                                          --
------------------------------------------------------------------------------
 
--  OpenVMS Version
 
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with System.Aux_DEC;
with System.CRTL;
with System.Task_Primitives.Operations;
package body System.Tasking.Debug is
 
   package OSI renames System.OS_Interface;
   package STPO renames System.Task_Primitives.Operations;
 
   use System.Aux_DEC;
 
   --  Condition value type
 
   subtype Cond_Value_Type is Unsigned_Longword;
 
   type Trace_Flag_Set is array (Character) of Boolean;
 
   Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
 
   --  Print_Routine fuction codes
 
   type Print_Functions is
     (No_Print, Print_Newline, Print_Control,
      Print_String, Print_Symbol, Print_FAO);
   for Print_Functions use
     (No_Print => 0, Print_Newline => 1, Print_Control => 2,
      Print_String => 3, Print_Symbol => 4, Print_FAO => 5);
 
   --  Counted ascii type declarations
 
   subtype Count_Type is Natural range 0 .. 255;
   for Count_Type'Object_Size use 8;
 
   type ASCIC (Count : Count_Type) is record
      Text  : String (1 .. Count);
   end record;
 
   for ASCIC use record
      Count at 0 range 0 .. 7;
   end record;
   pragma Pack (ASCIC);
 
   type AASCIC is access ASCIC;
   for AASCIC'Size use 32;
 
   type AASCIC_Array is array (Positive range <>) of AASCIC;
 
   type ASCIC127 is record
      Count : Count_Type;
      Text  : String (1 .. 127);
   end record;
 
   for ASCIC127 use record
      Count at 0 range 0 .. 7;
      Text  at 1 range 0 .. 127 * 8 - 1;
   end record;
 
   --  DEBUG Event record types used to signal DEBUG about Ada events
 
   type Debug_Event_Record is record
      Code     : Unsigned_Word; --  Event code that uniquely identifies event
      Flags    : Bit_Array_8;   --  Flag bits
      --                            Bit 0: This event allows a parameter list
      --                            Bit 1: Parameters are address expressions
      Sentinal : Unsigned_Byte; --  Sentinal valuye: Always K_EVENT_SENT
      TS_Kind  : Unsigned_Byte; --  DST type specification: Always K_TS_TASK
      DType    : Unsigned_Byte; --  DTYPE of parameter if of atomic data type
      --                            Always K_DTYPE_TASK
      MBZ      : Unsigned_Byte; --  Unused (must be zero)
      Minchr   : Count_Type;    --  Minimum chars needed to identify event
      Name     : ASCIC (31);    --  Event name uppercase only
      Help     : AASCIC;        --  Event description
   end record;
 
   for Debug_Event_Record use record
      Code     at 0 range 0 .. 15;
      Flags    at 2 range 0 .. 7;
      Sentinal at 3 range 0 .. 7;
      TS_Kind  at 4 range 0 .. 7;
      Dtype    at 5 range 0 .. 7;
      MBZ      at 6 range 0 .. 7;
      Minchr   at 7 range 0 .. 7;
      Name     at 8 range 0 .. 32 * 8 - 1;
      Help     at 40 range 0 .. 31;
   end record;
 
   type Ada_Event_Control_Block_Type is record
      Code      : Unsigned_Word;     --  Reserved and defined by DEBUG
      Unused1   : Unsigned_Byte;     --  Reserved and defined by DEBUG
      Sentinal  : Unsigned_Byte;     --  Reserved and defined by DEBUG
      Facility  : Unsigned_Word;     --  Reserved and defined by DEBUG
      Flags     : Unsigned_Word;     --  Reserved and defined by DEBUG
      Value     : Unsigned_Longword; --  Reserved and defined by DEBUG
      Unused2   : Unsigned_Longword; --  Reserved and defined by DEBUG
      Sigargs   : Unsigned_Longword;
      P1        : Unsigned_Longword;
      Sub_Event : Unsigned_Longword;
   end record;
 
   for Ada_Event_Control_Block_Type use record
      Code      at 0 range 0 .. 15;
      Unused1   at 2 range 0 .. 7;
      Sentinal  at 3 range 0 .. 7;
      Facility  at 4 range 0 .. 15;
      Flags     at 6 range 0 .. 15;
      Value     at 8 range 0 .. 31;
      Unused2   at 12 range 0 .. 31;
      Sigargs   at 16 range 0 .. 31;
      P1        at 20 range 0 .. 31;
      Sub_Event at 24 range 0 .. 31;
   end record;
 
   type Ada_Event_Control_Block_Access is access Ada_Event_Control_Block_Type;
   for Ada_Event_Control_Block_Access'Size use 32;
 
   --  Print_Routine_Type with max optional parameters
 
   type Print_Routine_Type is access procedure
     (Print_Function    : Print_Functions;
      Print_Subfunction : Print_Functions;
      P1                : Unsigned_Longword := 0;
      P2                : Unsigned_Longword := 0;
      P3                : Unsigned_Longword := 0;
      P4                : Unsigned_Longword := 0;
      P5                : Unsigned_Longword := 0;
      P6                : Unsigned_Longword := 0);
   for Print_Routine_Type'Size use 32;
 
   ---------------
   -- Constants --
   ---------------
 
   --  These are used to obtain and convert task values
   K_CVT_VALUE_NUM  : constant := 1;
   K_CVT_NUM_VALUE  : constant := 2;
   K_NEXT_TASK      : constant := 3;
 
   --  These are used to ask ADA to display task information
   K_SHOW_TASK     : constant := 4;
   K_SHOW_STAT     : constant := 5;
   K_SHOW_DEADLOCK : constant := 6;
 
   --  These are used to get and set various attributes of one or more tasks
   --    Task state
   --  K_GET_STATE  : constant := 7;
   --  K_GET_ACTIVE : constant := 8;
   --  K_SET_ACTIVE : constant := 9;
   K_SET_ABORT  : constant := 10;
   --  K_SET_HOLD   : constant := 11;
 
   --    Task priority
   K_GET_PRIORITY      : constant := 12;
   K_SET_PRIORITY      : constant := 13;
   K_RESTORE_PRIORITY  : constant := 14;
 
   --    Task registers
   --  K_GET_REGISTERS     : constant := 15;
   --  K_SET_REGISTERS     : constant := 16;
 
   --  These are used to control definable events
   K_ENABLE_EVENT   : constant := 17;
   K_DISABLE_EVENT  : constant := 18;
   K_ANNOUNCE_EVENT : constant := 19;
 
   --  These are used to control time-slicing.
   --  K_SHOW_TIME_SLICE : constant := 20;
   --  K_SET_TIME_SLICE  : constant := 21;
 
   --  This is used to symbolize task stack addresses.
   --  K_SYMBOLIZE_ADDRESS : constant := 22;
 
   K_GET_CALLER : constant := 23;
   --  This is used to obtain the task value of the caller task
 
   --  Miscellaneous functions - see below for details
 
   K_CLEANUP_EVENT  : constant := 24;
   K_SHOW_EVENT_DEF : constant := 25;
   --  K_CHECK_TASK_STACK : constant := 26;  --  why commented out ???
 
   --  This is used to obtain the DBGEXT-interface revision level
   --  K_GET_DBGEXT_REV : constant := 27; -- why commented out ???
 
   K_GET_STATE_1 : constant := 28;
   --  This is used to obtain additional state info, primarily for PCA
 
   K_FIND_EVENT_BY_CODE : constant := 29;
   K_FIND_EVENT_BY_NAME : constant := 30;
   --  These are used to search for user-defined event entries
 
   --  This is used to stop task schedulding. Why commented out ???
   --  K_STOP_ALL_OTHER_TASKS : constant := 31;
 
   --  Debug event constants
 
   K_TASK_NOT_EXIST  : constant := 3;
   K_SUCCESS         : constant := 1;
   K_EVENT_SENT      : constant := 16#9A#;
   K_TS_TASK         : constant := 18;
   K_DTYPE_TASK      : constant := 44;
 
   --  Status signal constants
 
   SS_BADPARAM       : constant := 20;
   SS_NORMAL         : constant := 1;
 
   --  Miscellaneous mask constants
 
   V_EVNT_ALL        : constant := 0;
   V_Full_Display    : constant := 11;
   V_Suppress_Header : constant := 13;
 
   --  CMA constants (why are some commented out???)
 
   CMA_C_DEBGET_GUARDSIZE     : constant := 1;
   CMA_C_DEBGET_IS_HELD       : constant := 2;
--   CMA_C_DEBGET_IS_INITIAL    : constant := 3;
--   CMA_C_DEBGET_NUMBER        : constant := 4;
   CMA_C_DEBGET_STACKPTR      : constant := 5;
   CMA_C_DEBGET_STACK_BASE    : constant := 6;
   CMA_C_DEBGET_STACK_TOP     : constant := 7;
   CMA_C_DEBGET_SCHED_STATE   : constant := 8;
   CMA_C_DEBGET_YELLOWSIZE    : constant := 9;
--   CMA_C_DEBGET_BASE_PRIO     : constant := 10;
--   CMA_C_DEBGET_REGS          : constant := 11;
--   CMA_C_DEBGET_ALT_PENDING   : constant := 12;
--   CMA_C_DEBGET_ALT_A_ENABLE  : constant := 13;
--   CMA_C_DEBGET_ALT_G_ENABLE  : constant := 14;
--   CMA_C_DEBGET_SUBSTATE      : constant := 15;
--   CMA_C_DEBGET_OBJECT_ADDR   : constant := 16;
--   CMA_C_DEBGET_THKIND        : constant := 17;
--   CMA_C_DEBGET_DETACHED      : constant := 18;
   CMA_C_DEBGET_TCB_SIZE      : constant := 19;
--   CMA_C_DEBGET_START_PC      : constant := 20;
--   CMA_C_DEBGET_NEXT_PC       : constant := 22;
--   CMA_C_DEBGET_POLICY        : constant := 23;
--   CMA_C_DEBGET_STACK_YELLOW  : constant := 24;
--   CMA_C_DEBGET_STACK_DEFAULT : constant := 25;
 
   --  Miscellaneous counted ascii constants
 
   Star     : constant AASCIC := new ASCIC'(2, ("* "));
   NoStar   : constant AASCIC := new ASCIC'(2, ("  "));
   Hold     : constant AASCIC := new ASCIC'(4, ("HOLD"));
   NoHold   : constant AASCIC := new ASCIC'(4, ("    "));
   Header   : constant AASCIC := new ASCIC '
     (60, ("  task id     pri hold state   substate          task object"));
   Empty_Text : constant AASCIC := new ASCIC (0);
 
   --  DEBUG Ada tasking states equated to their GNAT tasking equivalents
 
   Ada_State_Invalid_State     : constant AASCIC :=
     new ASCIC'(17, "Invalid state    ");
--   Ada_State_Abnormal          : constant AASCIC :=
--     new ASCIC'(17, "Abnormal         ");
   Ada_State_Aborting          : constant AASCIC :=
     new ASCIC'(17, "Aborting         "); --  Aborting (new)
--   Ada_State_Completed_Abn     : constant AASCIC :=
--     new ASCIC'(17, "Completed  [abn] ");
--   Ada_State_Completed_Exc     : constant AASCIC :=
--     new ASCIC'(17, "Completed  [exc] ");
   Ada_State_Completed         : constant AASCIC :=
     new ASCIC'(17, "Completed        "); --  Master_Completion_Sleep
   Ada_State_Runnable          : constant AASCIC :=
     new ASCIC'(17, "Runnable         "); --  Runnable
   Ada_State_Activating        : constant AASCIC :=
     new ASCIC'(17, "Activating       ");
   Ada_State_Accept            : constant AASCIC :=
     new ASCIC'(17, "Accept           "); --  Acceptor_Sleep
   Ada_State_Select_or_Delay   : constant AASCIC :=
     new ASCIC'(17, "Select or delay  "); --  Acceptor_Delay_Sleep
   Ada_State_Select_or_Term    : constant AASCIC :=
     new ASCIC'(17, "Select or term.  "); -- Terminate_Alternative
   Ada_State_Select_or_Abort   : constant AASCIC :=
     new ASCIC'(17, "Select or abort  "); --  Async_Select_Sleep (new)
--   Ada_State_Select            : constant AASCIC :=
--     new ASCIC'(17, "Select           ");
   Ada_State_Activating_Tasks  : constant AASCIC :=
     new ASCIC'(17, "Activating tasks "); --  Activator_Sleep
   Ada_State_Delay             : constant AASCIC :=
     new ASCIC'(17, "Delay            "); --  AST_Pending
--   Ada_State_Dependents        : constant AASCIC :=
--     new ASCIC'(17, "Dependents       ");
   Ada_State_Entry_Call        : constant AASCIC :=
     new ASCIC'(17, "Entry call       "); --  Entry_Caller_Sleep
   Ada_State_Cond_Entry_Call   : constant AASCIC :=
     new ASCIC'(17, "Cond. entry call "); --  Call.Mode.Conditional_Call
   Ada_State_Timed_Entry_Call  : constant AASCIC :=
     new ASCIC'(17, "Timed entry call "); --  Call.Mode.Timed_Call
   Ada_State_Async_Entry_Call  : constant AASCIC :=
     new ASCIC'(17, "Async entry call "); --  Call.Mode.Asynchronous_Call (new)
--   Ada_State_Dependents_Exc    : constant AASCIC :=
--     new ASCIC'(17, "Dependents [exc] ");
   Ada_State_IO_or_AST         : constant AASCIC :=
     new ASCIC'(17, "I/O or AST       "); --  AST_Server_Sleep
--   Ada_State_Shared_Resource   : constant AASCIC :=
--     new ASCIC'(17, "Shared resource  ");
   Ada_State_Not_Yet_Activated : constant AASCIC :=
     new ASCIC'(17, "Not yet activated"); --  Unactivated
--   Ada_State_Terminated_Abn    : constant AASCIC :=
--     new ASCIC'(17, "Terminated [abn] ");
--   Ada_State_Terminated_Exc    : constant AASCIC :=
--     new ASCIC'(17, "Terminated [exc] ");
   Ada_State_Terminated        : constant AASCIC :=
     new ASCIC'(17, "Terminated       "); --  Terminated
   Ada_State_Server            : constant AASCIC :=
     new ASCIC'(17, "Server           "); --  Servers
   Ada_State_Async_Hold        : constant AASCIC :=
     new ASCIC'(17, "Async_Hold       "); --  Async_Hold
 
   --  Task state counted ascii constants
 
   Debug_State_Emp : constant AASCIC := new ASCIC'(5, "     ");
   Debug_State_Run : constant AASCIC := new ASCIC'(5, "RUN  ");
   Debug_State_Rea : constant AASCIC := new ASCIC'(5, "READY");
   Debug_State_Sus : constant AASCIC := new ASCIC'(5, "SUSP ");
   Debug_State_Ter : constant AASCIC := new ASCIC'(5, "TERM ");
 
   --  Priority order of event display
 
   Global_Event_Display_Order : constant array (Event_Kind_Type)
     of Event_Kind_Type := (
      Debug_Event_Abort_Terminated,
      Debug_Event_Activating,
      Debug_Event_Dependents_Exception,
      Debug_Event_Exception_Terminated,
      Debug_Event_Handled,
      Debug_Event_Handled_Others,
      Debug_Event_Preempted,
      Debug_Event_Rendezvous_Exception,
      Debug_Event_Run,
      Debug_Event_Suspended,
      Debug_Event_Terminated);
 
   --  Constant array defining all debug events
 
   Event_Directory : constant array (Event_Kind_Type)
     of Debug_Event_Record := (
      (Debug_Event_Activating,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       2,
       (31, "ACTIVATING                     "),
       new ASCIC'(41, "!_a task is about to begin its activation")),
 
      (Debug_Event_Run,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       2,
       (31, "RUN                            "),
       new ASCIC'(24, "!_a task is about to run")),
 
      (Debug_Event_Suspended,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       1,
       (31, "SUSPENDED                      "),
       new ASCIC'(33, "!_a task is about to be suspended")),
 
      (Debug_Event_Preempted,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       1,
       (31, "PREEMPTED                      "),
       new ASCIC'(33, "!_a task is about to be preempted")),
 
      (Debug_Event_Terminated,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       1,
       (31, "TERMINATED                     "),
       new ASCIC'(57,
        "!_a task is terminating (including by abort or exception)")),
 
      (Debug_Event_Abort_Terminated,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       2,
       (31, "ABORT_TERMINATED               "),
       new ASCIC'(40, "!_a task is terminating because of abort")),
 
      (Debug_Event_Exception_Terminated,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       1,
       (31, "EXCEPTION_TERMINATED           "),
       new ASCIC'(47, "!_a task is terminating because of an exception")),
 
      (Debug_Event_Rendezvous_Exception,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       3,
       (31, "RENDEZVOUS_EXCEPTION           "),
       new ASCIC'(49, "!_an exception is propagating out of a rendezvous")),
 
      (Debug_Event_Handled,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       1,
       (31, "HANDLED                        "),
       new ASCIC'(37, "!_an exception is about to be handled")),
 
      (Debug_Event_Dependents_Exception,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       1,
       (31, "DEPENDENTS_EXCEPTION           "),
       new ASCIC'(64,
        "!_an exception is about to cause a task to await dependent tasks")),
 
      (Debug_Event_Handled_Others,
       (False, False, False, False, False, False, False, True),
       K_EVENT_SENT,
       K_TS_TASK,
       K_DTYPE_TASK,
       0,
       1,
       (31, "HANDLED_OTHERS                 "),
       new ASCIC'(58,
        "!_an exception is about to be handled in an OTHERS handler")));
 
   --  Help on events displayed in DEBUG
 
   Event_Def_Help : constant AASCIC_Array := (
     new ASCIC'(0,  ""),
     new ASCIC'(65,
      "  The general forms of commands to set a breakpoint or tracepoint"),
     new ASCIC'(22, "  on an Ada event are:"),
     new ASCIC'(73, "    SET BREAK/EVENT=event [task[, ... ]] " &
                    "[WHEN(expr)] [DO(comnd[; ... ])]"),
     new ASCIC'(73, "    SET TRACE/EVENT=event [task[, ... ]] " &
                    "[WHEN(expr)] [DO(comnd[; ... ])]"),
     new ASCIC'(0,  ""),
     new ASCIC'(65,
      "  If tasks are specified, the breakpoint will trigger only if the"),
     new ASCIC'(40, "  event occurs for those specific tasks."),
     new ASCIC'(0,  ""),
     new ASCIC'(39, "  Ada event names and their definitions"),
     new ASCIC'(0,  ""));
 
   -----------------------
   -- Package Variables --
   -----------------------
 
   AC_Buffer : ASCIC127;
 
   Events_Enabled_Count : Integer := 0;
 
   Print_Routine_Bufsiz : constant := 132;
   Print_Routine_Bufcnt : Integer := 0;
   Print_Routine_Linbuf : String (1 .. Print_Routine_Bufsiz);
 
   Global_Task_Debug_Events : Debug_Event_Array :=
     (False, False, False, False, False, False, False, False,
      False, False, False, False, False, False, False, False);
   --  Global table of task debug events set by the debugger
 
   --------------------------
   -- Exported Subprograms --
   --------------------------
 
   procedure Default_Print_Routine
     (Print_Function    : Print_Functions;
      Print_Subfunction : Print_Functions;
      P1                : Unsigned_Longword := 0;
      P2                : Unsigned_Longword := 0;
      P3                : Unsigned_Longword := 0;
      P4                : Unsigned_Longword := 0;
      P5                : Unsigned_Longword := 0;
      P6                : Unsigned_Longword := 0);
   --  The default print routine if not overridden.
   --  Print_Function determines option argument formatting.
   --  Print_Subfunction buffers output if No_Print, calls Put_Output if
   --  Print_Newline
 
   pragma Export_Procedure
     (Default_Print_Routine,
      Mechanism => (Value, Value, Reference, Reference, Reference));
 
   --------------------------
   -- Imported Subprograms --
   --------------------------
 
   procedure Debug_Get
     (Thread_Id : OSI.Thread_Id;
      Item_Req  : Unsigned_Word;
      Out_Buff  : System.Address;
      Buff_Siz  : Unsigned_Word);
 
   procedure Debug_Get
     (Thread_Id : OSI.Thread_Id;
      Item_Req  : Unsigned_Word;
      Out_Buff  : Unsigned_Longword;
      Buff_Siz  : Unsigned_Word);
   pragma Interface (External, Debug_Get);
 
   pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET",
     (OSI.Thread_Id, Unsigned_Word, System.Address, Unsigned_Word),
     (Reference, Value, Reference, Value));
 
   pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET",
     (OSI.Thread_Id, Unsigned_Word, Unsigned_Longword, Unsigned_Word),
     (Reference, Value, Reference, Value));
 
   procedure FAOL
     (Status : out Cond_Value_Type;
      Ctrstr : String;
      Outlen : out Unsigned_Word;
      Outbuf : out String;
      Prmlst : Unsigned_Longword_Array);
   pragma Interface (External, FAOL);
 
   pragma Import_Valued_Procedure (FAOL, "SYS$FAOL",
     (Cond_Value_Type, String, Unsigned_Word, String, Unsigned_Longword_Array),
     (Value, Descriptor (S), Reference, Descriptor (S), Reference));
 
   procedure Put_Output (
     Status         : out Cond_Value_Type;
     Message_String : String);
 
   procedure Put_Output (Message_String : String);
   pragma Interface (External, Put_Output);
 
   pragma Import_Valued_Procedure (Put_Output, "LIB$PUT_OUTPUT",
     (Cond_Value_Type, String),
     (Value, Short_Descriptor (S)));
 
   pragma Import_Procedure (Put_Output, "LIB$PUT_OUTPUT",
     (String),
     (Short_Descriptor (S)));
 
   procedure Signal
     (Condition_Value     : Cond_Value_Type;
      Number_Of_Arguments : Integer := Integer'Null_Parameter;
      FAO_Argument_1      : Unsigned_Longword :=
                              Unsigned_Longword'Null_Parameter);
   pragma Interface (External, Signal);
 
   pragma Import_Procedure (Signal, "LIB$SIGNAL",
      (Cond_Value_Type, Integer, Unsigned_Longword),
      (Value, Value, Value),
       Number_Of_Arguments);
 
   ----------------------------
   -- Generic Instantiations --
   ----------------------------
 
   function Fetch is new Fetch_From_Address (Unsigned_Longword);
   pragma Unreferenced (Fetch);
 
   procedure Free is new Ada.Unchecked_Deallocation
     (Object => Ada_Event_Control_Block_Type,
      Name   => Ada_Event_Control_Block_Access);
 
   function To_AASCIC is new
     Ada.Unchecked_Conversion (Unsigned_Longword, AASCIC);
 
   function To_Addr is new
     Ada.Unchecked_Conversion (Task_Procedure_Access, Address);
   pragma Unreferenced (To_Addr);
 
   function To_EVCB is new
     Ada.Unchecked_Conversion
      (Unsigned_Longword, Ada_Event_Control_Block_Access);
 
   function To_Integer is new
     Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address);
 
   function To_Print_Routine_Type is new
     Ada.Unchecked_Conversion (Short_Address, Print_Routine_Type);
 
   --  Optional argumements passed to Print_Routine have to be
   --  Unsigned_Longwords so define the required Unchecked_Conversions
 
   function To_UL is new
     Ada.Unchecked_Conversion (AASCIC, Unsigned_Longword);
 
   function To_UL is new
     Ada.Unchecked_Conversion (Integer, Unsigned_Longword);
 
   function To_UL is new
     Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword);
 
   pragma Warnings (Off); --  Different sizes
   function To_UL is new
     Ada.Unchecked_Conversion (Task_Entry_Index, Unsigned_Longword);
   pragma Warnings (On);
 
   function To_UL is new
     Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword);
 
   function To_UL is new
     Ada.Unchecked_Conversion
      (Ada_Event_Control_Block_Access, Unsigned_Longword);
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   subtype Function_Codes is System.Aux_DEC.Unsigned_Word range 1 .. 31;
   --  The 31 function codes sent by the debugger needed to implement
   --  tasking support, enumerated below.
 
   type Register_Array is array (Natural range 0 .. 16) of
     System.Aux_DEC.Unsigned_Longword;
   --  The register array is a holdover from VAX and not used
   --  on Alpha or I64 but is kept as a filler below.
 
   type DBGEXT_Control_Block (Function_Code : Function_Codes) is record
      Facility_ID         : System.Aux_DEC.Unsigned_Word;
      --  For GNAT use the "Ada" facility ID
      Status              : System.Aux_DEC.Unsigned_Longword;
      --  Successful or otherwise returned status
      Flags               : System.Aux_DEC.Bit_Array_32;
      --   Used to flag event as global
      Print_Routine       : System.Aux_DEC.Short_Address;
      --  The print subprogram the caller wants to use for output
      Event_Code_or_EVCB  : System.Aux_DEC.Unsigned_Longword;
      --  Dual use Event Code or EVent Control Block
      Event_Value_or_Name : System.Aux_DEC.Unsigned_Longword;
      --  Dual use Event Value or Event Name string pointer
      Event_Entry         : System.Aux_DEC.Unsigned_Longword;
      Task_Value          : Task_Id;
      Task_Number         : Integer;
      Ada_Flags           : System.Aux_DEC.Bit_Array_32;
      Priority            : System.Aux_DEC.Bit_Array_32;
      Active_Registers    : System.Aux_DEC.Short_Address;
 
      case Function_Code is
         when K_GET_STATE_1 =>
            Base_Priority       : System.Aux_DEC.Bit_Array_32;
            Task_Type_Name      : System.Aux_DEC.Short_Address;
            Creation_PC         : System.Aux_DEC.Short_Address;
            Parent_Task_ID      : Task_Id;
 
         when others =>
            Ignored_Unused      : Register_Array;
 
      end case;
   end record;
 
   for DBGEXT_Control_Block use record
      Function_Code       at 0  range 0 .. 15;
      Facility_ID         at 2  range 0 .. 15;
      Status              at 4  range 0 .. 31;
      Flags               at 8  range 0 .. 31;
      Print_Routine       at 12 range 0 .. 31;
      Event_Code_or_EVCB  at 16 range 0 .. 31;
      Event_Value_or_Name at 20 range 0 .. 31;
      Event_Entry         at 24 range 0 .. 31;
      Task_Value          at 28 range 0 .. 31;
      Task_Number         at 32 range 0 .. 31;
      Ada_Flags           at 36 range 0 .. 31;
      Priority            at 40 range 0 .. 31;
      Active_Registers    at 44 range 0 .. 31;
      Ignored_Unused      at 48 range 0 .. 17 * 32 - 1;
      Base_Priority       at 48 range 0 .. 31;
      Task_Type_Name      at 52 range 0 .. 31;
      Creation_PC         at 56 range 0 .. 31;
      Parent_Task_ID      at 60 range 0 .. 31;
   end record;
 
   type DBGEXT_Control_Block_Access is access all DBGEXT_Control_Block;
 
   function DBGEXT (Control_Block : DBGEXT_Control_Block_Access)
     return System.Aux_DEC.Unsigned_Word;
   --  Exported to s-taprop.adb to avoid having a VMS specific s-tasdeb.ads
   pragma Convention (C, DBGEXT);
   pragma Export_Function (DBGEXT, "GNAT$DBGEXT");
   --  This routine is called by CMA when VMS DEBUG wants the Gnat RTL
   --  to give it some assistance (primarily when tasks are debugged).
   --
   --  The single parameter is an "external control block". On input to
   --  the Gnat RTL this control block determines the debugging function
   --  to be performed, and supplies parameters.  This routine cases on
   --  the function code, and calls the appropriate Gnat RTL routine,
   --  which returns values by modifying the external control block.
 
   procedure Announce_Event
      (Event_EVCB    : Unsigned_Longword;
       Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
   --  Announce the occurence of a DEBUG tasking event
 
   procedure Cleanup_Event (Event_EVCB : Unsigned_Longword);
   --  After DEBUG has processed an event that has signalled, the signaller
   --  must cleanup. Cleanup consists of freeing the event control block.
 
   procedure Disable_Event
      (Flags       : Bit_Array_32;
       Event_Value : Unsigned_Longword;
       Event_Code  : Unsigned_Longword;
       Status      : out Cond_Value_Type);
   --  Disable a DEBUG tasking event
 
   function DoAC (S : String) return Address;
   --  Convert a string to the address of an internal buffer containing
   --  the counted ASCII.
 
   procedure Enable_Event
      (Flags       : Bit_Array_32;
       Event_Value : Unsigned_Longword;
       Event_Code  : Unsigned_Longword;
       Status      : out Cond_Value_Type);
   --  Enable a requested DEBUG tasking event
 
   procedure Find_Event_By_Code
      (Event_Code  : Unsigned_Longword;
       Event_Entry : out Unsigned_Longword;
       Status      : out Cond_Value_Type);
   --  Convert an event code to the address of the event entry
 
   procedure Find_Event_By_Name
      (Event_Name  : Unsigned_Longword;
       Event_Entry : out Unsigned_Longword;
       Status      : out Cond_Value_Type);
   --  Find an event entry given the event name
 
   procedure List_Entry_Waiters
     (Task_Value      : Task_Id;
      Full_Display    : Boolean := False;
      Suppress_Header : Boolean := False;
      Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access);
   --  List information about tasks waiting on an entry
 
   procedure Put (S : String);
   --  Display S on standard output
 
   procedure Put_Line (S : String := "");
   --  Display S on standard output with an additional line terminator
 
   procedure Show_Event
      (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access);
   --  Show what events are available
 
   procedure Show_One_Task
     (Task_Value      : Task_Id;
      Full_Display    : Boolean := False;
      Suppress_Header : Boolean := False;
      Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access);
   --  Display information about one task
 
   procedure Show_Rendezvous
     (Task_Value      : Task_Id;
      Ada_State       : AASCIC := Empty_Text;
      Full_Display    : Boolean := False;
      Suppress_Header : Boolean := False;
      Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access);
   --  Display information about a task rendezvous
 
   procedure Trace_Output (Message_String : String);
   --  Call Put_Output if Trace_on ("VMS")
 
   procedure Write (Fd : Integer; S : String; Count : Integer);
 
   --------------------
   -- Announce_Event --
   --------------------
 
   procedure Announce_Event
      (Event_EVCB    : Unsigned_Longword;
       Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
   is
      EVCB : constant Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB);
 
      Event_Kind : constant Event_Kind_Type :=
                     (if EVCB.Sub_Event /= 0
                      then Event_Kind_Type (EVCB.Sub_Event)
                      else Event_Kind_Type (EVCB.Code));
 
      TI : constant String := "   Task %TASK !UI is ";
      --  Announce prefix
 
   begin
      Trace_Output ("Announce called");
 
      case Event_Kind is
         when Debug_Event_Activating =>
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC (TI & "about to begin its activation")),
              EVCB.Value);
         when Debug_Event_Exception_Terminated =>
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC (TI & "terminating because of an exception")),
              EVCB.Value);
         when Debug_Event_Run =>
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC (TI & "about to run")),
              EVCB.Value);
         when Debug_Event_Abort_Terminated =>
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC (TI & "terminating because of abort")),
              EVCB.Value);
         when Debug_Event_Terminated =>
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC (TI & "terminating normally")),
              EVCB.Value);
         when others => null;
      end case;
   end Announce_Event;
 
   -------------------
   -- Cleanup_Event --
   -------------------
 
   procedure Cleanup_Event (Event_EVCB  : Unsigned_Longword) is
      EVCB : Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB);
   begin
      Free (EVCB);
   end Cleanup_Event;
 
   ------------------------
   -- Continue_All_Tasks --
   ------------------------
 
   procedure Continue_All_Tasks is
   begin
      null; --  VxWorks
   end Continue_All_Tasks;
 
   ------------
   -- DBGEXT --
   ------------
 
   function DBGEXT
     (Control_Block : DBGEXT_Control_Block_Access)
      return System.Aux_DEC.Unsigned_Word
   is
      Print_Routine : Print_Routine_Type := Default_Print_Routine'Access;
   begin
      Trace_Output ("DBGEXT called");
 
      if Control_Block.Print_Routine /= Address_Zero then
         Print_Routine := To_Print_Routine_Type (Control_Block.Print_Routine);
      end if;
 
      case Control_Block.Function_Code is
 
         --  Convert a task value to a task number.
         --  The output results are stored in the CONTROL_BLOCK.
 
         when K_CVT_VALUE_NUM =>
            Trace_Output ("DBGEXT param 1 - CVT Value to NUM");
            Control_Block.Task_Number :=
              Control_Block.Task_Value.Known_Tasks_Index + 1;
            Control_Block.Status := K_SUCCESS;
            Trace_Output ("Task Number: ");
            Trace_Output (Integer'Image (Control_Block.Task_Number));
            return SS_NORMAL;
 
         --  Convert a task number to a task value.
         --  The output results are stored in the CONTROL_BLOCK.
 
         when K_CVT_NUM_VALUE =>
            Trace_Output ("DBGEXT param 2 - CVT NUM to Value");
            Trace_Output ("Task Number: ");
            Trace_Output (Integer'Image (Control_Block.Task_Number));
            Control_Block.Task_Value :=
              Known_Tasks (Control_Block.Task_Number - 1);
            Control_Block.Status := K_SUCCESS;
            Trace_Output ("Task Value: ");
            Trace_Output (Unsigned_Longword'Image
              (To_UL (Control_Block.Task_Value)));
            return SS_NORMAL;
 
         --  Obtain the "next" task after a specified task.
         --  ??? To do: If specified check the PRIORITY, STATE, and HOLD
         --  fields to restrict the selection of the next task.
         --  The output results are stored in the CONTROL_BLOCK.
 
         when K_NEXT_TASK =>
            Trace_Output ("DBGEXT param 3 - Next Task");
            Trace_Output ("Task Value: ");
            Trace_Output (Unsigned_Longword'Image
              (To_UL (Control_Block.Task_Value)));
 
            if Control_Block.Task_Value = null then
               Control_Block.Task_Value := Known_Tasks (Known_Tasks'First);
            else
               Control_Block.Task_Value :=
                 Known_Tasks (Control_Block.Task_Value.Known_Tasks_Index + 1);
            end if;
 
            if Control_Block.Task_Value = null then
               Control_Block.Task_Value := Known_Tasks (Known_Tasks'First);
            end if;
 
            Control_Block.Status := K_SUCCESS;
            return SS_NORMAL;
 
         --  Display the state of a task. The FULL bit is checked to decide if
         --  a full or brief task display is desired. The output results are
         --  stored in the CONTROL_BLOCK.
 
         when K_SHOW_TASK =>
            Trace_Output ("DBGEXT param 4 - Show Task");
 
            if Control_Block.Task_Value = null then
               Control_Block.Status := K_TASK_NOT_EXIST;
            else
               Show_One_Task
                 (Control_Block.Task_Value,
                  Control_Block.Ada_Flags (V_Full_Display),
                  Control_Block.Ada_Flags (V_Suppress_Header),
                  Print_Routine);
 
               Control_Block.Status := K_SUCCESS;
            end if;
 
            return SS_NORMAL;
 
         --  Enable a requested DEBUG tasking event
 
         when K_ENABLE_EVENT =>
            Trace_Output ("DBGEXT param 17 - Enable Event");
            Enable_Event
              (Control_Block.Flags,
               Control_Block.Event_Value_or_Name,
               Control_Block.Event_Code_or_EVCB,
               Control_Block.Status);
 
            return SS_NORMAL;
 
         --  Disable a DEBUG tasking event
 
         when K_DISABLE_EVENT =>
            Trace_Output ("DBGEXT param 18 - Disable Event");
            Disable_Event
              (Control_Block.Flags,
               Control_Block.Event_Value_or_Name,
               Control_Block.Event_Code_or_EVCB,
               Control_Block.Status);
 
            return SS_NORMAL;
 
         --  Announce the occurence of a DEBUG tasking event
 
         when K_ANNOUNCE_EVENT =>
            Trace_Output ("DBGEXT param 19 - Announce Event");
            Announce_Event
              (Control_Block.Event_Code_or_EVCB,
               Print_Routine);
 
            Control_Block.Status := K_SUCCESS;
            return SS_NORMAL;
 
         --  After DEBUG has processed an event that has signalled,
         --  the signaller must cleanup.
         --  Cleanup consists of freeing the event control block.
 
         when K_CLEANUP_EVENT =>
            Trace_Output ("DBGEXT param 24 - Cleanup Event");
            Cleanup_Event (Control_Block.Event_Code_or_EVCB);
 
            Control_Block.Status := K_SUCCESS;
            return SS_NORMAL;
 
         --  Show what events are available
 
         when K_SHOW_EVENT_DEF =>
            Trace_Output ("DBGEXT param 25 - Show Event Def");
            Show_Event (Print_Routine);
 
            Control_Block.Status := K_SUCCESS;
            return SS_NORMAL;
 
         --  Convert an event code to the address of the event entry
 
         when K_FIND_EVENT_BY_CODE =>
            Trace_Output ("DBGEXT param 29 - Find Event by Code");
            Find_Event_By_Code
              (Control_Block.Event_Code_or_EVCB,
               Control_Block.Event_Entry,
               Control_Block.Status);
 
            return SS_NORMAL;
 
         --  Find an event entry given the event name
 
         when K_FIND_EVENT_BY_NAME =>
            Trace_Output ("DBGEXT param 30 - Find Event by Name");
            Find_Event_By_Name
              (Control_Block.Event_Value_or_Name,
               Control_Block.Event_Entry,
               Control_Block.Status);
            return SS_NORMAL;
 
         --  ??? To do: Implement priority events
         --  Get, set or restore a task's priority
 
         when K_GET_PRIORITY or K_SET_PRIORITY or K_RESTORE_PRIORITY =>
            Trace_Output ("DBGEXT priority param - Not yet implemented");
            Trace_Output (Function_Codes'Image
             (Control_Block.Function_Code));
            return SS_BADPARAM;
 
         --  ??? To do: Implement show statistics event
         --  Display task statistics
 
         when K_SHOW_STAT =>
            Trace_Output ("DBGEXT show stat param - Not yet implemented");
            Trace_Output (Function_Codes'Image
             (Control_Block.Function_Code));
            return SS_BADPARAM;
 
         --  ??? To do: Implement get caller event
         --  Obtain the caller of a task in a rendezvous. If no rendezvous,
         --  null is returned
 
         when K_GET_CALLER =>
            Trace_Output ("DBGEXT get caller param - Not yet implemented");
            Trace_Output (Function_Codes'Image
             (Control_Block.Function_Code));
            return SS_BADPARAM;
 
         --  ??? To do: Implement set terminate event
         --  Terminate a task
 
         when K_SET_ABORT =>
            Trace_Output ("DBGEXT set terminate param - Not yet implemented");
            Trace_Output (Function_Codes'Image
             (Control_Block.Function_Code));
            return SS_BADPARAM;
 
         --  ??? To do: Implement show deadlock event
         --  Detect a deadlock
 
         when K_SHOW_DEADLOCK =>
            Trace_Output ("DBGEXT show deadlock param - Not yet implemented");
            Trace_Output (Function_Codes'Image
             (Control_Block.Function_Code));
            return SS_BADPARAM;
 
         when others =>
            Trace_Output ("DBGEXT bad param: ");
            Trace_Output (Function_Codes'Image
             (Control_Block.Function_Code));
            return SS_BADPARAM;
 
      end case;
   end DBGEXT;
 
   ---------------------------
   -- Default_Print_Routine --
   ---------------------------
 
   procedure Default_Print_Routine
     (Print_Function    : Print_Functions;
      Print_Subfunction : Print_Functions;
      P1                : Unsigned_Longword := 0;
      P2                : Unsigned_Longword := 0;
      P3                : Unsigned_Longword := 0;
      P4                : Unsigned_Longword := 0;
      P5                : Unsigned_Longword := 0;
      P6                : Unsigned_Longword := 0)
   is
      Status    : Cond_Value_Type;
      Linlen    : Unsigned_Word;
      Item_List : Unsigned_Longword_Array (1 .. 17) :=
        (1 .. 17 => 0);
   begin
 
      case Print_Function is
         when Print_Control | Print_String =>
            null;
 
         --  Formatted Ascii Output
 
         when Print_FAO =>
            Item_List (1) := P2;
            Item_List (2) := P3;
            Item_List (3) := P4;
            Item_List (4) := P5;
            Item_List (5) := P6;
            FAOL
              (Status,
               To_AASCIC (P1).Text,
               Linlen,
               Print_Routine_Linbuf
                 (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz),
               Item_List);
 
            Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen);
 
         --  Symbolic output
 
         when Print_Symbol =>
            Item_List (1) := P1;
            FAOL
              (Status,
               "!XI",
               Linlen,
               Print_Routine_Linbuf
                 (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz),
               Item_List);
 
            Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen);
 
         when others =>
            null;
      end case;
 
      case Print_Subfunction is
 
         --  Output buffer with a terminating newline
 
         when Print_Newline =>
            Put_Output (Status,
              Print_Routine_Linbuf (1 .. Print_Routine_Bufcnt));
            Print_Routine_Bufcnt := 0;
 
         --  Buffer the output
 
         when No_Print =>
            null;
 
         when others =>
            null;
      end case;
 
   end Default_Print_Routine;
 
   -------------------
   -- Disable_Event --
   -------------------
 
   procedure Disable_Event
      (Flags       : Bit_Array_32;
       Event_Value : Unsigned_Longword;
       Event_Code  : Unsigned_Longword;
       Status      : out Cond_Value_Type)
   is
      Task_Value : Task_Id;
      Task_Index : constant Integer := Integer (Event_Value) - 1;
   begin
 
      Events_Enabled_Count := Events_Enabled_Count - 1;
 
      if Flags (V_EVNT_ALL) then
         Global_Task_Debug_Events (Integer (Event_Code)) := False;
         Status := K_SUCCESS;
      else
         if Task_Index in Known_Tasks'Range then
            Task_Value := Known_Tasks (Task_Index);
            if Task_Value /= null then
               Task_Value.Common.Debug_Events (Integer (Event_Code)) := False;
               Status := K_SUCCESS;
            else
               Status := K_TASK_NOT_EXIST;
            end if;
         else
            Status := K_TASK_NOT_EXIST;
         end if;
      end if;
 
      --  Keep count of events for efficiency
 
      if Events_Enabled_Count <= 0 then
         Events_Enabled_Count := 0;
         Global_Task_Debug_Event_Set := False;
      end if;
 
   end Disable_Event;
 
   ----------
   -- DoAC --
   ----------
 
   function DoAC (S : String) return Address is
   begin
      AC_Buffer.Count := S'Length;
      AC_Buffer.Text (1 .. AC_Buffer.Count) := S;
      return AC_Buffer'Address;
   end DoAC;
 
   ------------------
   -- Enable_Event --
   ------------------
 
   procedure Enable_Event
      (Flags       : Bit_Array_32;
       Event_Value : Unsigned_Longword;
       Event_Code  : Unsigned_Longword;
       Status      : out Cond_Value_Type)
   is
      Task_Value : Task_Id;
      Task_Index : constant Integer := Integer (Event_Value) - 1;
   begin
 
      --  At least one event enabled, any and all events will cause a
      --  condition to be raised and checked. Major tasking slowdown!
 
      Global_Task_Debug_Event_Set := True;
      Events_Enabled_Count := Events_Enabled_Count + 1;
 
      if Flags (V_EVNT_ALL) then
         Global_Task_Debug_Events (Integer (Event_Code)) := True;
         Status := K_SUCCESS;
      else
         if Task_Index in Known_Tasks'Range then
            Task_Value := Known_Tasks (Task_Index);
            if Task_Value /= null then
               Task_Value.Common.Debug_Events (Integer (Event_Code)) := True;
               Status := K_SUCCESS;
            else
               Status := K_TASK_NOT_EXIST;
            end if;
         else
            Status := K_TASK_NOT_EXIST;
         end if;
      end if;
 
   end Enable_Event;
 
   ------------------------
   -- Find_Event_By_Code --
   ------------------------
 
   procedure Find_Event_By_Code
      (Event_Code  : Unsigned_Longword;
       Event_Entry : out Unsigned_Longword;
       Status      : out Cond_Value_Type)
   is
      K_SUCCESS        : constant := 1;
      K_NO_SUCH_EVENT  : constant := 9;
 
   begin
      Trace_Output ("Looking for Event: ");
      Trace_Output (Unsigned_Longword'Image (Event_Code));
 
      for I in Event_Kind_Type'Range loop
         if Event_Code = Unsigned_Longword (Event_Directory (I).Code) then
            Event_Entry := To_UL (Event_Directory (I)'Address);
            Trace_Output ("Found Event # ");
            Trace_Output (Integer'Image (I));
            Status := K_SUCCESS;
            return;
         end if;
      end loop;
 
      Status := K_NO_SUCH_EVENT;
   end Find_Event_By_Code;
 
   ------------------------
   -- Find_Event_By_Name --
   ------------------------
 
   procedure Find_Event_By_Name
      (Event_Name  : Unsigned_Longword;
       Event_Entry : out Unsigned_Longword;
       Status      : out Cond_Value_Type)
   is
      K_SUCCESS        : constant := 1;
      K_NO_SUCH_EVENT  : constant := 9;
 
      Event_Name_Cstr : constant ASCIC := To_AASCIC (Event_Name).all;
   begin
      Trace_Output ("Looking for Event: ");
      Trace_Output (Event_Name_Cstr.Text);
 
      for I in Event_Kind_Type'Range loop
         if Event_Name_Cstr.Count >= Event_Directory (I).Minchr
            and then Event_Name_Cstr.Count <= Event_Directory (I).Name.Count
            and then Event_Name_Cstr.Text (1 .. Event_Directory (I).Minchr) =
                Event_Directory (I).Name.Text (1 .. Event_Directory (I).Minchr)
         then
            Event_Entry := To_UL (Event_Directory (I)'Address);
            Trace_Output ("Found Event # ");
            Trace_Output (Integer'Image (I));
            Status := K_SUCCESS;
            return;
         end if;
      end loop;
 
      Status := K_NO_SUCH_EVENT;
   end Find_Event_By_Name;
 
   --------------------
   -- Get_User_State --
   --------------------
 
   function Get_User_State return Long_Integer is
   begin
      return STPO.Self.User_State;
   end Get_User_State;
 
   ------------------------
   -- List_Entry_Waiters --
   ------------------------
 
   procedure List_Entry_Waiters
     (Task_Value      : Task_Id;
      Full_Display    : Boolean := False;
      Suppress_Header : Boolean := False;
      Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access)
   is
      pragma Unreferenced (Suppress_Header);
 
      Entry_Call : Entry_Call_Link;
      Have_Some  : Boolean := False;
   begin
      if not Full_Display then
         return;
      end if;
 
      if Task_Value.Entry_Queues'Length > 0 then
         Print_Routine (Print_FAO, Print_Newline,
           To_UL (DoAC ("        Waiting entry callers:")));
      end if;
      for I in Task_Value.Entry_Queues'Range loop
         Entry_Call := Task_Value.Entry_Queues (I).Head;
         if Entry_Call /= null then
            Have_Some := True;
 
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC ("          Waiters for entry !UI:")),
              To_UL (I));
 
            loop
               declare
                  Task_Image : ASCIC :=
                   (Entry_Call.Self.Common.Task_Image_Len,
                    Entry_Call.Self.Common.Task_Image
                     (1 .. Entry_Call.Self.Common.Task_Image_Len));
               begin
                  Print_Routine (Print_FAO, Print_Newline,
                    To_UL (DoAC ("              %TASK !UI, type: !AC")),
                    To_UL (Entry_Call.Self.Known_Tasks_Index + 1),
                    To_UL (Task_Image'Address));
                  if Entry_Call = Task_Value.Entry_Queues (I).Tail then
                     exit;
                  end if;
                  Entry_Call := Entry_Call.Next;
               end;
            end loop;
         end if;
      end loop;
      if not Have_Some then
         Print_Routine (Print_FAO, Print_Newline,
           To_UL (DoAC ("          none.")));
      end if;
   end List_Entry_Waiters;
 
   ----------------
   -- List_Tasks --
   ----------------
 
   procedure List_Tasks is
      C : Task_Id;
   begin
      C := All_Tasks_List;
 
      while C /= null loop
         Print_Task_Info (C);
         C := C.Common.All_Tasks_Link;
      end loop;
   end List_Tasks;
 
   ------------------------
   -- Print_Current_Task --
   ------------------------
 
   procedure Print_Current_Task is
   begin
      Print_Task_Info (STPO.Self);
   end Print_Current_Task;
 
   ---------------------
   -- Print_Task_Info --
   ---------------------
 
   procedure Print_Task_Info (T : Task_Id) is
      Entry_Call : Entry_Call_Link;
      Parent     : Task_Id;
 
   begin
      if T = null then
         Put_Line ("null task");
         return;
      end if;
 
      Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " &
           Task_States'Image (T.Common.State));
 
      Parent := T.Common.Parent;
 
      if Parent = null then
         Put (", parent: <none>");
      else
         Put (", parent: " &
              Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len));
      end if;
 
      Put (", prio:" & T.Common.Current_Priority'Img);
 
      if not T.Callable then
         Put (", not callable");
      end if;
 
      if T.Aborting then
         Put (", aborting");
      end if;
 
      if T.Deferral_Level /= 0 then
         Put (", abort deferred");
      end if;
 
      if T.Common.Call /= null then
         Entry_Call := T.Common.Call;
         Put (", serving:");
 
         while Entry_Call /= null loop
            Put (To_Integer (Entry_Call.Self)'Img);
            Entry_Call := Entry_Call.Acceptor_Prev_Call;
         end loop;
      end if;
 
      if T.Open_Accepts /= null then
         Put (", accepting:");
 
         for J in T.Open_Accepts'Range loop
            Put (T.Open_Accepts (J).S'Img);
         end loop;
 
         if T.Terminate_Alternative then
            Put (" or terminate");
         end if;
      end if;
 
      if T.User_State /= 0 then
         Put (", state:" & T.User_State'Img);
      end if;
 
      Put_Line;
   end Print_Task_Info;
 
   ---------
   -- Put --
   ---------
 
   procedure Put (S : String) is
   begin
      Write (2, S, S'Length);
   end Put;
 
   --------------
   -- Put_Line --
   --------------
 
   procedure Put_Line (S : String := "") is
   begin
      Write (2, S & ASCII.LF, S'Length + 1);
   end Put_Line;
 
   ----------------------
   -- Resume_All_Tasks --
   ----------------------
 
   procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
      pragma Unreferenced (Thread_Self);
   begin
      null; --  VxWorks
   end Resume_All_Tasks;
 
   ---------------
   -- Set_Trace --
   ---------------
 
   procedure Set_Trace (Flag  : Character; Value : Boolean := True) is
   begin
      Trace_On (Flag) := Value;
   end Set_Trace;
 
   --------------------
   -- Set_User_State --
   --------------------
 
   procedure Set_User_State (Value : Long_Integer) is
   begin
      STPO.Self.User_State := Value;
   end Set_User_State;
 
   ----------------
   -- Show_Event --
   ----------------
 
   procedure Show_Event
      (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access)
   is
   begin
      for I in Event_Def_Help'Range loop
         Print_Routine (Print_FAO, Print_Newline, To_UL (Event_Def_Help (I)));
      end loop;
 
      for I in Event_Kind_Type'Range loop
         Print_Routine (Print_FAO, Print_Newline,
           To_UL (Event_Directory
                   (Global_Event_Display_Order (I)).Name'Address));
         Print_Routine (Print_FAO, Print_Newline,
           To_UL (Event_Directory (Global_Event_Display_Order (I)).Help));
      end loop;
   end Show_Event;
 
   --------------------
   -- Show_One_Task --
   --------------------
 
   procedure Show_One_Task
     (Task_Value      : Task_Id;
      Full_Display    : Boolean := False;
      Suppress_Header : Boolean := False;
      Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access)
   is
      Task_SP            : System.Address := Address_Zero;
      Stack_Base         : System.Address := Address_Zero;
      Stack_Top          : System.Address := Address_Zero;
      TCB_Size           : Unsigned_Longword := 0;
      CMA_TCB_Size       : Unsigned_Longword := 0;
      Stack_Guard_Size   : Unsigned_Longword := 0;
      Total_Task_Storage : Unsigned_Longword := 0;
      Stack_In_Use       : Unsigned_Longword := 0;
      Reserved_Size      : Unsigned_Longword := 0;
      Hold_Flag          : Unsigned_Longword := 0;
      Sched_State        : Unsigned_Longword := 0;
      User_Prio          : Unsigned_Longword := 0;
      Stack_Size         : Unsigned_Longword := 0;
      Run_State          : Boolean := False;
      Rea_State          : Boolean := False;
      Sus_State          : Boolean := False;
      Ter_State          : Boolean := False;
 
      Current_Flag : AASCIC := NoStar;
      Hold_String  : AASCIC := NoHold;
      Ada_State    : AASCIC := Ada_State_Invalid_State;
      Debug_State  : AASCIC := Debug_State_Emp;
 
      Ada_State_Len   : constant Unsigned_Longword := 17;
      Debug_State_Len : constant Unsigned_Longword := 5;
 
      Entry_Call : Entry_Call_Record;
 
   begin
 
      --  Initialize local task info variables
 
      Task_SP := Address_Zero;
      Stack_Base := Address_Zero;
      Stack_Top := Address_Zero;
      CMA_TCB_Size := 0;
      Stack_Guard_Size := 0;
      Reserved_Size := 0;
      Hold_Flag := 0;
      Sched_State := 0;
      TCB_Size := Unsigned_Longword (Task_Id'Size);
 
      if not Suppress_Header or else Full_Display then
         Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
         Print_Routine (Print_FAO, Print_Newline, To_UL (Header));
      end if;
 
      Trace_Output ("Show_One_Task Task Value: ");
      Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value)));
 
      --  Callback to DEBUG to get some task info
 
      if Task_Value.Common.State /= Terminated then
         Debug_Get
           (STPO.Get_Thread_Id (Task_Value),
            CMA_C_DEBGET_STACKPTR,
            Task_SP,
            8);
 
         Debug_Get
           (STPO.Get_Thread_Id (Task_Value),
            CMA_C_DEBGET_TCB_SIZE,
            CMA_TCB_Size,
            4);
 
         Debug_Get
           (STPO.Get_Thread_Id (Task_Value),
            CMA_C_DEBGET_GUARDSIZE,
            Stack_Guard_Size,
            4);
 
         Debug_Get
           (STPO.Get_Thread_Id (Task_Value),
            CMA_C_DEBGET_YELLOWSIZE,
            Reserved_Size,
            4);
 
         Debug_Get
           (STPO.Get_Thread_Id (Task_Value),
            CMA_C_DEBGET_STACK_BASE,
            Stack_Base,
            8);
 
         Debug_Get
           (STPO.Get_Thread_Id (Task_Value),
            CMA_C_DEBGET_STACK_TOP,
            Stack_Top,
            8);
 
         Stack_Size := Unsigned_Longword (Stack_Base - Stack_Top)
           - Reserved_Size - Stack_Guard_Size;
         Stack_In_Use := Unsigned_Longword (Stack_Base - Task_SP) + 4;
         Total_Task_Storage := TCB_Size + Stack_Size + Stack_Guard_Size
           + Reserved_Size + CMA_TCB_Size;
 
         Debug_Get
           (STPO.Get_Thread_Id (Task_Value),
            CMA_C_DEBGET_IS_HELD,
            Hold_Flag,
            4);
 
         Hold_String := (if Hold_Flag /= 0 then Hold else NoHold);
 
         Debug_Get
           (STPO.Get_Thread_Id (Task_Value),
            CMA_C_DEBGET_SCHED_STATE,
            Sched_State,
            4);
      end if;
 
      Run_State := False;
      Rea_State := False;
      Sus_State := Task_Value.Common.State = Unactivated;
      Ter_State := Task_Value.Common.State = Terminated;
 
      if not Ter_State then
         Run_State := Sched_State = 0;
         Rea_State := Sched_State = 1;
         Sus_State := Sched_State /= 0 and Sched_State /= 1;
      end if;
 
      --  Set the debug state
 
      if Run_State then
         Debug_State := Debug_State_Run;
      elsif Rea_State then
         Debug_State := Debug_State_Rea;
      elsif Sus_State then
         Debug_State := Debug_State_Sus;
      elsif Ter_State then
         Debug_State := Debug_State_Ter;
      end if;
 
      Trace_Output ("Before case State: ");
      Trace_Output (Task_States'Image (Task_Value.Common.State));
 
      --  Set the Ada state
 
      case Task_Value.Common.State is
         when Unactivated =>
            Ada_State := Ada_State_Not_Yet_Activated;
 
         when Activating =>
            Ada_State := Ada_State_Activating;
 
         when Runnable =>
            Ada_State := Ada_State_Runnable;
 
         when Terminated =>
            Ada_State := Ada_State_Terminated;
 
         when Activator_Sleep =>
            Ada_State := Ada_State_Activating_Tasks;
 
         when Acceptor_Sleep =>
            Ada_State := Ada_State_Accept;
 
         when Acceptor_Delay_Sleep =>
            Ada_State := Ada_State_Select_or_Delay;
 
         when Entry_Caller_Sleep =>
            Entry_Call :=
              Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level);
 
            case Entry_Call.Mode is
               when Simple_Call =>
                  Ada_State := Ada_State_Entry_Call;
               when Conditional_Call =>
                  Ada_State := Ada_State_Cond_Entry_Call;
               when Timed_Call =>
                  Ada_State := Ada_State_Timed_Entry_Call;
               when Asynchronous_Call =>
                  Ada_State := Ada_State_Async_Entry_Call;
            end case;
 
         when Async_Select_Sleep =>
            Ada_State := Ada_State_Select_or_Abort;
 
         when Delay_Sleep =>
            Ada_State := Ada_State_Delay;
 
         when Master_Completion_Sleep =>
            Ada_State := Ada_State_Completed;
 
         when Master_Phase_2_Sleep =>
            Ada_State := Ada_State_Completed;
 
         when Interrupt_Server_Idle_Sleep |
              Interrupt_Server_Blocked_Interrupt_Sleep |
              Timer_Server_Sleep |
              Interrupt_Server_Blocked_On_Event_Flag =>
            Ada_State := Ada_State_Server;
 
         when AST_Server_Sleep =>
            Ada_State := Ada_State_IO_or_AST;
 
         when Asynchronous_Hold =>
            Ada_State := Ada_State_Async_Hold;
 
      end case;
 
      if Task_Value.Terminate_Alternative then
         Ada_State := Ada_State_Select_or_Term;
      end if;
 
      if Task_Value.Aborting then
         Ada_State := Ada_State_Aborting;
      end if;
 
      User_Prio := To_UL (Task_Value.Common.Current_Priority);
      Trace_Output ("After user_prio");
 
      --  Flag the current task
 
      Current_Flag := (if Task_Value = Self then Star else NoStar);
 
      --  Show task info
 
      Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!AC%TASK !5<!UI!>")),
        To_UL (Current_Flag), To_UL (Task_Value.Known_Tasks_Index + 1));
 
      Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!2UB")), User_Prio);
 
      Print_Routine (Print_FAO, No_Print, To_UL (DoAC (" !AC !5AD !17AD ")),
        To_UL (Hold_String), Debug_State_Len, To_UL (Debug_State),
        Ada_State_Len, To_UL (Ada_State));
 
--      Print_Routine (Print_Symbol, Print_Newline,
--         Fetch (To_Addr (Task_Value.Common.Task_Entry_Point)));
 
      Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
 
      --  If /full qualfier passed, show detailed info
 
      if Full_Display then
         Show_Rendezvous (Task_Value, Ada_State, Full_Display,
           Suppress_Header, Print_Routine);
 
         List_Entry_Waiters (Task_Value, Full_Display,
           Suppress_Header, Print_Routine);
 
         Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text));
 
         declare
            Task_Image : ASCIC := (Task_Value.Common.Task_Image_Len,
              Task_Value.Common.Task_Image
               (1 .. Task_Value.Common.Task_Image_Len));
         begin
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC ("        Task type:      !AC")),
              To_UL (Task_Image'Address));
         end;
 
         --  How to find Creation_PC ???
--         Print_Routine (Print_FAO, No_Print,
--           To_UL (DoAC ("        Created at PC:  ")),
--         Print_Routine (Print_FAO, Print_Newline, Creation_PC);
 
         if Task_Value.Common.Parent /= null then
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC ("        Parent task:    %TASK !UI")),
              To_UL (Task_Value.Common.Parent.Known_Tasks_Index + 1));
         else
            Print_Routine (Print_FAO, Print_Newline,
             To_UL (DoAC ("        Parent task:    none")));
         end if;
 
--         Print_Routine (Print_FAO, No_Print,
--           To_UL (DoAC ("        Start PC:       ")));
--         Print_Routine (Print_Symbol, Print_Newline,
--            Fetch (To_Addr (Task_Value.Common.Task_Entry_Point)));
 
         Print_Routine (Print_FAO, Print_Newline,
          To_UL (DoAC (
           "        Task control block:             Stack storage (bytes):")));
 
         Print_Routine (Print_FAO, Print_Newline,
          To_UL (DoAC (
           "          Task value:   !10<!UI!>        RESERVED_BYTES:  !10UI")),
          To_UL (Task_Value), Reserved_Size);
 
         Print_Routine (Print_FAO, Print_Newline,
          To_UL (DoAC (
           "          Entries:      !10<!UI!>        TOP_GUARD_SIZE:  !10UI")),
          To_UL (Task_Value.Entry_Num), Stack_Guard_Size);
 
         Print_Routine (Print_FAO, Print_Newline,
          To_UL (DoAC (
           "          Size:         !10<!UI!>        STORAGE_SIZE:    !10UI")),
          TCB_Size + CMA_TCB_Size, Stack_Size);
 
         Print_Routine (Print_FAO, Print_Newline,
          To_UL (DoAC (
           "        Stack addresses:                 Bytes in use:    !10UI")),
          Stack_In_Use);
 
         Print_Routine (Print_FAO, Print_Newline,
          To_UL (DoAC ("          Top address:  !10<!XI!>")),
          To_UL (Stack_Top));
 
         Print_Routine (Print_FAO, Print_Newline,
          To_UL (DoAC (
           "          Base address: !10<!XI!>      Total storage:     !10UI")),
          To_UL (Stack_Base), Total_Task_Storage);
      end if;
 
   end Show_One_Task;
 
   ---------------------
   -- Show_Rendezvous --
   ---------------------
 
   procedure Show_Rendezvous
     (Task_Value      : Task_Id;
      Ada_State       : AASCIC := Empty_Text;
      Full_Display    : Boolean := False;
      Suppress_Header : Boolean := False;
      Print_Routine   : Print_Routine_Type := Default_Print_Routine'Access)
   is
      pragma Unreferenced (Ada_State);
      pragma Unreferenced (Suppress_Header);
 
      Temp_Entry  : Entry_Index;
      Entry_Call  : Entry_Call_Record;
      Called_Task : Task_Id;
      AWR         : constant String := "        Awaiting rendezvous at: ";
      --  Common prefix
 
      procedure Print_Accepts;
      --  Display information about task rendezvous accepts
 
      procedure Print_Accepts is
      begin
         if Task_Value.Open_Accepts /= null then
            for I in Task_Value.Open_Accepts'Range loop
               Temp_Entry := Entry_Index (Task_Value.Open_Accepts (I).S);
               declare
                  Entry_Name_Image : ASCIC :=
                    (Task_Value.Entry_Names (Temp_Entry).all'Length,
                     Task_Value.Entry_Names (Temp_Entry).all);
               begin
                  Trace_Output ("Accept at: " & Entry_Name_Image.Text);
                  Print_Routine (Print_FAO, Print_Newline,
                    To_UL (DoAC ("             accept at: !AC")),
                    To_UL (Entry_Name_Image'Address));
               end;
            end loop;
         end if;
      end Print_Accepts;
   begin
      if not Full_Display then
         return;
      end if;
 
      Trace_Output ("Show_Rendezvous Task Value: ");
      Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value)));
 
      if Task_Value.Common.State = Acceptor_Sleep and then
         not Task_Value.Terminate_Alternative
      then
         if Task_Value.Open_Accepts /= null then
            Temp_Entry := Entry_Index (Task_Value.Open_Accepts
              (Task_Value.Open_Accepts'First).S);
            declare
               Entry_Name_Image : ASCIC :=
                 (Task_Value.Entry_Names (Temp_Entry).all'Length,
                  Task_Value.Entry_Names (Temp_Entry).all);
            begin
               Trace_Output (AWR & "accept " & Entry_Name_Image.Text);
               Print_Routine (Print_FAO, Print_Newline,
                 To_UL (DoAC (AWR & "accept !AC")),
                 To_UL (Entry_Name_Image'Address));
            end;
 
         else
            Print_Routine (Print_FAO, Print_Newline,
              To_UL (DoAC ("        entry name unavailable")));
         end if;
      else
         case Task_Value.Common.State is
            when Acceptor_Sleep =>
               Print_Routine (Print_FAO, Print_Newline,
                 To_UL (DoAC (AWR & "select with terminate.")));
               Print_Accepts;
 
            when Async_Select_Sleep =>
               Print_Routine (Print_FAO, Print_Newline,
                 To_UL (DoAC (AWR & "select.")));
               Print_Accepts;
 
            when Acceptor_Delay_Sleep =>
               Print_Routine (Print_FAO, Print_Newline,
                 To_UL (DoAC (AWR & "select with delay.")));
               Print_Accepts;
 
            when Entry_Caller_Sleep =>
               Entry_Call :=
                 Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level);
 
               case Entry_Call.Mode is
                  when Simple_Call =>
                     Print_Routine (Print_FAO, Print_Newline,
                       To_UL (DoAC (AWR & "entry call")));
                  when Conditional_Call =>
                     Print_Routine (Print_FAO, Print_Newline,
                       To_UL (DoAC (AWR & "entry call with else")));
                  when Timed_Call =>
                     Print_Routine (Print_FAO, Print_Newline,
                       To_UL (DoAC (AWR & "entry call with delay")));
                  when Asynchronous_Call =>
                     Print_Routine (Print_FAO, Print_Newline,
                        To_UL (DoAC (AWR & "entry call with abort")));
               end case;
               Called_Task := Entry_Call.Called_Task;
               declare
                  Task_Image : ASCIC := (Called_Task.Common.Task_Image_Len,
                    Called_Task.Common.Task_Image
                     (1 .. Called_Task.Common.Task_Image_Len));
                  Entry_Name_Image : ASCIC :=
                    (Called_Task.Entry_Names (Entry_Call.E).all'Length,
                     Called_Task.Entry_Names (Entry_Call.E).all);
               begin
                  Print_Routine (Print_FAO, Print_Newline,
                    To_UL (DoAC
                     ("        for entry !AC in %TASK !UI type !AC")),
                    To_UL (Entry_Name_Image'Address),
                    To_UL (Called_Task.Known_Tasks_Index),
                    To_UL (Task_Image'Address));
               end;
 
            when others =>
               return;
         end case;
      end if;
 
   end Show_Rendezvous;
 
   ------------------------
   -- Signal_Debug_Event --
   ------------------------
 
   procedure Signal_Debug_Event
    (Event_Kind : Event_Kind_Type; Task_Value : Task_Id)
   is
      Do_Signal : Boolean;
      EVCB      : Ada_Event_Control_Block_Access;
 
      EVCB_Sent    : constant := 16#9B#;
      Ada_Facility : constant := 49;
      SS_DBGEVENT  : constant := 1729;
   begin
      Do_Signal := Global_Task_Debug_Events (Event_Kind);
 
      if not Do_Signal then
         if Task_Value /= null then
            Do_Signal := Do_Signal
              or else Task_Value.Common.Debug_Events (Event_Kind);
         end if;
      end if;
 
      if Do_Signal then
         --  Build an a tasking event control block and signal DEBUG
 
         EVCB := new Ada_Event_Control_Block_Type;
         EVCB.Code := Unsigned_Word (Event_Kind);
         EVCB.Sentinal := EVCB_Sent;
         EVCB.Facility := Ada_Facility;
 
         if Task_Value /= null then
            EVCB.Value := Unsigned_Longword (Task_Value.Known_Tasks_Index + 1);
         else
            EVCB.Value := 0;
         end if;
 
         EVCB.Sub_Event := 0;
         EVCB.P1 := 0;
         EVCB.Sigargs := 0;
         EVCB.Flags := 0;
         EVCB.Unused1 := 0;
         EVCB.Unused2 := 0;
 
         Signal (SS_DBGEVENT, 1, To_UL (EVCB));
      end if;
   end Signal_Debug_Event;
 
   --------------------
   -- Stop_All_Tasks --
   --------------------
 
   procedure Stop_All_Tasks is
   begin
      null; --  VxWorks
   end Stop_All_Tasks;
 
   ----------------------------
   -- Stop_All_Tasks_Handler --
   ----------------------------
 
   procedure Stop_All_Tasks_Handler is
   begin
      null; --  VxWorks
   end Stop_All_Tasks_Handler;
 
   -----------------------
   -- Suspend_All_Tasks --
   -----------------------
 
   procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
      pragma Unreferenced (Thread_Self);
   begin
      null; --  VxWorks
   end Suspend_All_Tasks;
 
   ------------------------
   -- Task_Creation_Hook --
   ------------------------
 
   procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
      pragma Unreferenced (Thread);
   begin
      null; --  VxWorks
   end Task_Creation_Hook;
 
   ---------------------------
   -- Task_Termination_Hook --
   ---------------------------
 
   procedure Task_Termination_Hook is
   begin
      null; --  VxWorks
   end Task_Termination_Hook;
 
   -----------
   -- Trace --
   -----------
 
   procedure Trace
     (Self_Id  : Task_Id;
      Msg      : String;
      Flag     : Character;
      Other_Id : Task_Id := null)
   is
   begin
      if Trace_On (Flag) then
         Put (To_Integer (Self_Id)'Img &
              ':' & Flag & ':' &
              Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) &
              ':');
 
         if Other_Id /= null then
            Put (To_Integer (Other_Id)'Img & ':');
         end if;
 
         Put_Line (Msg);
      end if;
   end Trace;
 
   ------------------
   -- Trace_Output --
   ------------------
 
   procedure Trace_Output (Message_String : String) is
   begin
      if Trace_On ('V') and Trace_On ('M') and Trace_On ('S') then
         Put_Output (Message_String);
      end if;
   end Trace_Output;
 
   -----------
   -- Write --
   -----------
 
   procedure Write (Fd : Integer; S : String; Count : Integer) is
      Discard : System.CRTL.ssize_t;
      pragma Unreferenced (Discard);
   begin
      Discard := System.CRTL.write (Fd, S (S'First)'Address,
                                    System.CRTL.size_t (Count));
      --  Is it really right to ignore write errors here ???
   end Write;
 
end System.Tasking.Debug;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tasdeb-vms.adb] - Blame information for rev 801

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
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