Patchwork [Ada] Add missing VMS run-time files

login
register
mail settings
Submitter Arnaud Charlet
Date Dec. 15, 2011, 3:30 p.m.
Message ID <20111215153009.GA18372@adacore.com>
Download mbox | patch
Permalink /patch/131669/
State New
Headers show

Comments

Arnaud Charlet - Dec. 15, 2011, 3:30 p.m.
This patch adds missing run-time files to get GNAT building on IA64 VMS.

Committed on trunk.

2011-12-15  Arnaud Charlet  <charlet@adacore.com>

	* a-numaux-vms.ads, s-asthan-vms-ia64.adb, s-auxdec-vms-ia64.adb,       
	s-memory-vms_64.adb, s-memory-vms_64.ads, s-osinte-vms-ia64.adb,
	s-osinte-vms-ia64.ads, s-tasdeb-vms.adb: New files.

Patch

Index: a-numaux-vms.ads
===================================================================
--- a-numaux-vms.ads	(revision 0)
+++ a-numaux-vms.ads	(revision 0)
@@ -0,0 +1,104 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                     A D A . N U M E R I C S . A U X                      --
+--                                                                          --
+--                                 S p e c                                  --
+--                             (VMS Version)                                --
+--                                                                          --
+--          Copyright (C) 2003-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/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package provides the basic computational interface for the generic
+--  elementary functions. The C library version interfaces with the routines
+--  in the C mathematical library, and is thus quite portable, although it may
+--  not necessarily meet the requirements for accuracy in the numerics annex.
+
+--  This is the VMS version
+
+package Ada.Numerics.Aux is
+   pragma Pure;
+
+   type Double is digits 15;
+   pragma Float_Representation (IEEE_Float, Double);
+   --  Type Double is the type used to call the C routines. Note that this
+   --  is IEEE format even when running on VMS with VAX_Native representation
+   --  since we use the IEEE version of the C library with VMS.
+
+   --  We import these functions directly from C. Note that we label them
+   --  all as pure functions, because indeed all of them are in fact pure!
+
+   function Sin (X : Double) return Double;
+   pragma Import (C, Sin, "MATH$SIN_T");
+   pragma Pure_Function (Sin);
+
+   function Cos (X : Double) return Double;
+   pragma Import (C, Cos, "MATH$COS_T");
+   pragma Pure_Function (Cos);
+
+   function Tan (X : Double) return Double;
+   pragma Import (C, Tan, "MATH$TAN_T");
+   pragma Pure_Function (Tan);
+
+   function Exp (X : Double) return Double;
+   pragma Import (C, Exp, "MATH$EXP_T");
+   pragma Pure_Function (Exp);
+
+   function Sqrt (X : Double) return Double;
+   pragma Import (C, Sqrt, "MATH$SQRT_T");
+   pragma Pure_Function (Sqrt);
+
+   function Log (X : Double) return Double;
+   pragma Import (C, Log, "DECC$TLOG_2");
+   pragma Pure_Function (Log);
+
+   function Acos (X : Double) return Double;
+   pragma Import (C, Acos, "MATH$ACOS_T");
+   pragma Pure_Function (Acos);
+
+   function Asin (X : Double) return Double;
+   pragma Import (C, Asin, "MATH$ASIN_T");
+   pragma Pure_Function (Asin);
+
+   function Atan (X : Double) return Double;
+   pragma Import (C, Atan, "MATH$ATAN_T");
+   pragma Pure_Function (Atan);
+
+   function Sinh (X : Double) return Double;
+   pragma Import (C, Sinh, "MATH$SINH_T");
+   pragma Pure_Function (Sinh);
+
+   function Cosh (X : Double) return Double;
+   pragma Import (C, Cosh, "MATH$COSH_T");
+   pragma Pure_Function (Cosh);
+
+   function Tanh (X : Double) return Double;
+   pragma Import (C, Tanh, "MATH$TANH_T");
+   pragma Pure_Function (Tanh);
+
+   function Pow (X, Y : Double) return Double;
+   pragma Import (C, Pow, "DECC$TPOW_2");
+   pragma Pure_Function (Pow);
+
+end Ada.Numerics.Aux;
Index: s-asthan-vms-ia64.adb
===================================================================
--- s-asthan-vms-ia64.adb	(revision 0)
+++ s-asthan-vms-ia64.adb	(revision 0)
@@ -0,0 +1,608 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                        GNAT RUN-TIME COMPONENTS                          --
+--                                                                          --
+--                  S Y S T E M . A S T _ H A N D L I N G                   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--         Copyright (C) 1996-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/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the OpenVMS/IA64 version
+
+with System; use System;
+
+with System.IO;
+
+with System.Machine_Code;
+with System.Parameters;
+
+with System.Tasking;
+with System.Tasking.Rendezvous;
+with System.Tasking.Initialization;
+with System.Tasking.Utilities;
+
+with System.Task_Primitives;
+with System.Task_Primitives.Operations;
+with System.Task_Primitives.Operations.DEC;
+
+with Ada.Finalization;
+with Ada.Task_Attributes;
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+package body System.AST_Handling is
+
+   package ATID renames Ada.Task_Identification;
+
+   package SP   renames System.Parameters;
+   package ST   renames System.Tasking;
+   package STR  renames System.Tasking.Rendezvous;
+   package STI  renames System.Tasking.Initialization;
+   package STU  renames System.Tasking.Utilities;
+
+   package STPO renames System.Task_Primitives.Operations;
+   package STPOD renames System.Task_Primitives.Operations.DEC;
+
+   AST_Lock : aliased System.Task_Primitives.RTS_Lock;
+   --  This is a global lock; it is used to execute in mutual exclusion
+   --  from all other AST tasks.  It is only used by Lock_AST and
+   --  Unlock_AST.
+
+   procedure Lock_AST (Self_ID : ST.Task_Id);
+   --  Locks out other AST tasks. Preceding a section of code by Lock_AST and
+   --  following it by Unlock_AST creates a critical region.
+
+   procedure Unlock_AST (Self_ID : ST.Task_Id);
+   --  Releases lock previously set by call to Lock_AST.
+   --  All nested locks must be released before other tasks competing for the
+   --  tasking lock are released.
+
+   --------------
+   -- Lock_AST --
+   --------------
+
+   procedure Lock_AST (Self_ID : ST.Task_Id) is
+   begin
+      STI.Defer_Abort_Nestable (Self_ID);
+      STPO.Write_Lock (AST_Lock'Access, Global_Lock => True);
+   end Lock_AST;
+
+   ----------------
+   -- Unlock_AST --
+   ----------------
+
+   procedure Unlock_AST (Self_ID : ST.Task_Id) is
+   begin
+      STPO.Unlock (AST_Lock'Access, Global_Lock => True);
+      STI.Undefer_Abort_Nestable (Self_ID);
+   end Unlock_AST;
+
+   ---------------------------------
+   -- AST_Handler Data Structures --
+   ---------------------------------
+
+   --  As noted in the private part of the spec of System.Aux_DEC, the
+   --  AST_Handler type is simply a pointer to a procedure that takes
+   --  a single 64bit parameter. The following is a local copy
+   --  of that definition.
+
+   --  We need our own copy because we need to get our hands on this
+   --  and we cannot see the private part of System.Aux_DEC. We don't
+   --  want to be a child of Aux_Dec because of complications resulting
+   --  from the use of pragma Extend_System. We will use unchecked
+   --  conversions between the two versions of the declarations.
+
+   type AST_Handler is access procedure (Param : Long_Integer);
+
+   --  However, this declaration is somewhat misleading, since the values
+   --  referenced by AST_Handler values (all produced in this package by
+   --  calls to Create_AST_Handler) are highly stylized.
+
+   --  The first point is that in VMS/I64, procedure pointers do not in
+   --  fact point to code, but rather to a procedure descriptor.
+   --  So a value of type AST_Handler is in fact a pointer to one of
+   --  descriptors.
+
+   type Descriptor_Type is
+   record
+      Entry_Point : System.Address;
+      GP_Value    : System.Address;
+   end record;
+   for  Descriptor_Type'Alignment use Standard'Maximum_Alignment;
+   --  pragma Warnings (Off, Descriptor_Type);
+   --  Suppress harmless warnings about alignment.
+   --  Should explain why this warning is harmless ???
+
+   type Descriptor_Ref is access all Descriptor_Type;
+
+   --  Normally, there is only one such descriptor for a given procedure, but
+   --  it works fine to make a copy of the single allocated descriptor, and
+   --  use the copy itself, and we take advantage of this in the design here.
+   --  The idea is that AST_Handler values will all point to a record with the
+   --  following structure:
+
+   --  Note: When we say it works fine, there is one delicate point, which
+   --  is that the code for the AST procedure itself requires the original
+   --  descriptor address.  We handle this by saving the orignal descriptor
+   --  address in this structure and restoring in Process_AST.
+
+   type AST_Handler_Data is record
+      Descriptor              : Descriptor_Type;
+      Original_Descriptor_Ref : Descriptor_Ref;
+      Taskid                  : ATID.Task_Id;
+      Entryno                 : Natural;
+   end record;
+
+   type AST_Handler_Data_Ref is access all AST_Handler_Data;
+
+   function To_AST_Handler is new Ada.Unchecked_Conversion
+     (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler);
+
+   --  Each time Create_AST_Handler is called, a new value of this record
+   --  type is created, containing a copy of the procedure descriptor for
+   --  the routine used to handle all AST's (Process_AST), and the Task_Id
+   --  and entry number parameters identifying the task entry involved.
+
+   --  The AST_Handler value returned is a pointer to this record. Since
+   --  the record starts with the procedure descriptor, it can be used
+   --  by the system in the normal way to call the procedure. But now
+   --  when the procedure gets control, it can determine the address of
+   --  the procedure descriptor used to call it (since the ABI specifies
+   --  that this is left sitting in register r27 on entry), and then use
+   --  that address to retrieve the Task_Id and entry number so that it
+   --  knows on which entry to queue the AST request.
+
+   --  The next issue is where are these records placed. Since we intend
+   --  to pass pointers to these records to asynchronous system service
+   --  routines, they have to be on the heap, which means we have to worry
+   --  about when to allocate them and deallocate them.
+
+   --  We solve this problem by introducing a task attribute that points to
+   --  a vector, indexed by the entry number, of AST_Handler_Data records
+   --  for a given task. The pointer itself is a controlled object allowing
+   --  us to write a finalization routine that frees the referenced vector.
+
+   --  An entry in this vector is either initialized (Entryno non-zero) and
+   --  can be used for any subsequent reference to the same entry, or it is
+   --  unused, marked by the Entryno value being zero.
+
+   type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
+   type AST_Handler_Vector_Ref is access all AST_Handler_Vector;
+
+   type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
+      Vector : AST_Handler_Vector_Ref;
+   end record;
+
+   procedure Finalize (Obj : in out AST_Vector_Ptr);
+   --  Override Finalize so that the AST Vector gets freed.
+
+   procedure Finalize (Obj : in out AST_Vector_Ptr) is
+      procedure Free is new
+       Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref);
+   begin
+      if Obj.Vector /= null then
+         Free (Obj.Vector);
+      end if;
+   end Finalize;
+
+   AST_Vector_Init : AST_Vector_Ptr;
+   --  Initial value, treated as constant, Vector will be null
+
+   package AST_Attribute is new Ada.Task_Attributes
+     (Attribute     => AST_Vector_Ptr,
+      Initial_Value => AST_Vector_Init);
+
+   use AST_Attribute;
+
+   -----------------------
+   -- AST Service Queue --
+   -----------------------
+
+   --  The following global data structures are used to queue pending
+   --  AST requests. When an AST is signalled, the AST service routine
+   --  Process_AST is called, and it makes an entry in this structure.
+
+   type AST_Instance is record
+      Taskid  : ATID.Task_Id;
+      Entryno : Natural;
+      Param   : Long_Integer;
+   end record;
+   --  The Taskid and Entryno indicate the entry on which this AST is to
+   --  be queued, and Param is the parameter provided from the AST itself.
+
+   AST_Service_Queue_Size  : constant := 256;
+   AST_Service_Queue_Limit : constant := 250;
+   type AST_Service_Queue_Index is mod AST_Service_Queue_Size;
+   --  Index used to refer to entries in the circular buffer which holds
+   --  active AST_Instance values. The upper bound reflects the maximum
+   --  number of AST instances that can be stored in the buffer. Since
+   --  these entries are immediately serviced by the high priority server
+   --  task that does the actual entry queuing, it is very unusual to have
+   --  any significant number of entries simulaneously queued.
+
+   AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
+   pragma Volatile_Components (AST_Service_Queue);
+   --  The circular buffer used to store active AST requests
+
+   AST_Service_Queue_Put : AST_Service_Queue_Index := 0;
+   AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
+   pragma Atomic (AST_Service_Queue_Put);
+   pragma Atomic (AST_Service_Queue_Get);
+   --  These two variables point to the next slots in the AST_Service_Queue
+   --  to be used for putting a new entry in and taking an entry out. This
+   --  is a circular buffer, so these pointers wrap around. If the two values
+   --  are equal the buffer is currently empty. The pointers are atomic to
+   --  ensure proper synchronization between the single producer (namely the
+   --  Process_AST procedure), and the single consumer (the AST_Service_Task).
+
+   --------------------------------
+   -- AST Server Task Structures --
+   --------------------------------
+
+   --  The basic approach is that when an AST comes in, a call is made to
+   --  the Process_AST procedure. It queues the request in the service queue
+   --  and then wakes up an AST server task to perform the actual call to the
+   --  required entry. We use this intermediate server task, since the AST
+   --  procedure itself cannot wait to return, and we need some caller for
+   --  the rendezvous so that we can use the normal rendezvous mechanism.
+
+   --  It would work to have only one AST server task, but then we would lose
+   --  all overlap in AST processing, and furthermore, we could get priority
+   --  inversion effects resulting in starvation of AST requests.
+
+   --  We therefore maintain a small pool of AST server tasks. We adjust
+   --  the size of the pool dynamically to reflect traffic, so that we have
+   --  a sufficient number of server tasks to avoid starvation.
+
+   Max_AST_Servers : constant Natural := 16;
+   --  Maximum number of AST server tasks that can be allocated
+
+   Num_AST_Servers : Natural := 0;
+   --  Number of AST server tasks currently active
+
+   Num_Waiting_AST_Servers : Natural := 0;
+   --  This is the number of AST server tasks that are either waiting for
+   --  work, or just about to go to sleep and wait for work.
+
+   Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False);
+   --  An array of flags showing which AST server tasks are currently waiting
+
+   AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id;
+   --  Task Id's of allocated AST server tasks
+
+   task type AST_Server_Task (Num : Natural) is
+      pragma Priority (Priority'Last);
+   end AST_Server_Task;
+   --  Declaration for AST server task. This task has no entries, it is
+   --  controlled by sleep and wakeup calls at the task primitives level.
+
+   type AST_Server_Task_Ptr is access all AST_Server_Task;
+   --  Type used to allocate server tasks
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Allocate_New_AST_Server;
+   --  Allocate an additional AST server task
+
+   procedure Process_AST (Param : Long_Integer);
+   --  This is the central routine for processing all AST's, it is referenced
+   --  as the code address of all created AST_Handler values. See detailed
+   --  description in body to understand how it works to have a single such
+   --  procedure for all AST's even though it does not get any indication of
+   --  the entry involved passed as an explicit parameter. The single explicit
+   --  parameter Param is the parameter passed by the system with the AST.
+
+   -----------------------------
+   -- Allocate_New_AST_Server --
+   -----------------------------
+
+   procedure Allocate_New_AST_Server is
+      Dummy : AST_Server_Task_Ptr;
+      pragma Unreferenced (Dummy);
+
+   begin
+      if Num_AST_Servers = Max_AST_Servers then
+         return;
+
+      else
+         --  Note: it is safe to increment Num_AST_Servers immediately, since
+         --  no one will try to activate this task until it indicates that it
+         --  is sleeping by setting its entry in Is_Waiting to True.
+
+         Num_AST_Servers := Num_AST_Servers + 1;
+         Dummy := new AST_Server_Task (Num_AST_Servers);
+      end if;
+   end Allocate_New_AST_Server;
+
+   ---------------------
+   -- AST_Server_Task --
+   ---------------------
+
+   task body AST_Server_Task is
+      Taskid  : ATID.Task_Id;
+      Entryno : Natural;
+      Param   : aliased Long_Integer;
+      Self_Id : constant ST.Task_Id := ST.Self;
+
+      pragma Volatile (Param);
+
+   begin
+      --  By making this task independent of master, when the environment
+      --  task is finalizing, the AST_Server_Task will be notified that it
+      --  should terminate.
+
+      STU.Make_Independent;
+
+      --  Record our task Id for access by Process_AST
+
+      AST_Task_Ids (Num) := Self_Id;
+
+      --  Note: this entire task operates with the main task lock set, except
+      --  when it is sleeping waiting for work, or busy doing a rendezvous
+      --  with an AST server. This lock protects the data structures that
+      --  are shared by multiple instances of the server task.
+
+      Lock_AST (Self_Id);
+
+      --  This is the main infinite loop of the task. We go to sleep and
+      --  wait to be woken up by Process_AST when there is some work to do.
+
+      loop
+         Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1;
+
+         Unlock_AST (Self_Id);
+
+         STI.Defer_Abort (Self_Id);
+
+         if SP.Single_Lock then
+            STPO.Lock_RTS;
+         end if;
+
+         STPO.Write_Lock (Self_Id);
+
+         Is_Waiting (Num) := True;
+
+         Self_Id.Common.State := ST.AST_Server_Sleep;
+         STPO.Sleep (Self_Id, ST.AST_Server_Sleep);
+         Self_Id.Common.State := ST.Runnable;
+
+         STPO.Unlock (Self_Id);
+
+         if SP.Single_Lock then
+            STPO.Unlock_RTS;
+         end if;
+
+         --  If the process is finalizing, Undefer_Abort will simply end
+         --  this task.
+
+         STI.Undefer_Abort (Self_Id);
+
+         --  We are awake, there is something to do!
+
+         Lock_AST (Self_Id);
+         Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1;
+
+         --  Loop here to service outstanding requests. We are always
+         --  locked on entry to this loop.
+
+         while AST_Service_Queue_Get /= AST_Service_Queue_Put loop
+            Taskid  := AST_Service_Queue (AST_Service_Queue_Get).Taskid;
+            Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno;
+            Param   := AST_Service_Queue (AST_Service_Queue_Get).Param;
+
+            AST_Service_Queue_Get := AST_Service_Queue_Get + 1;
+
+            --  This is a manual expansion of the normal call simple code
+
+            declare
+               type AA is access all Long_Integer;
+               P : AA := Param'Unrestricted_Access;
+
+               function To_ST_Task_Id is new Ada.Unchecked_Conversion
+                 (ATID.Task_Id, ST.Task_Id);
+
+            begin
+               Unlock_AST (Self_Id);
+               STR.Call_Simple
+                 (Acceptor           => To_ST_Task_Id (Taskid),
+                  E                  => ST.Task_Entry_Index (Entryno),
+                  Uninterpreted_Data => P'Address);
+
+            exception
+               when E : others =>
+                  System.IO.Put_Line ("%Debugging event");
+                  System.IO.Put_Line (Exception_Name (E) &
+                    " raised when trying to deliver an AST.");
+
+                  if Exception_Message (E)'Length /= 0 then
+                     System.IO.Put_Line (Exception_Message (E));
+                  end if;
+
+                  System.IO.Put_Line ("Task type is " & "Receiver_Type");
+                  System.IO.Put_Line ("Task id is " & ATID.Image (Taskid));
+            end;
+
+            Lock_AST (Self_Id);
+         end loop;
+      end loop;
+   end AST_Server_Task;
+
+   ------------------------
+   -- Create_AST_Handler --
+   ------------------------
+
+   function Create_AST_Handler
+     (Taskid  : ATID.Task_Id;
+      Entryno : Natural) return System.Aux_DEC.AST_Handler
+   is
+      Attr_Ref : Attribute_Handle;
+
+      Process_AST_Ptr : constant AST_Handler := Process_AST'Access;
+      --  Reference to standard procedure descriptor for Process_AST
+
+      function To_Descriptor_Ref is new Ada.Unchecked_Conversion
+        (AST_Handler, Descriptor_Ref);
+
+      Original_Descriptor_Ref : constant Descriptor_Ref :=
+                                  To_Descriptor_Ref (Process_AST_Ptr);
+
+   begin
+      if ATID.Is_Terminated (Taskid) then
+         raise Program_Error;
+      end if;
+
+      Attr_Ref := Reference (Taskid);
+
+      --  Allocate another server if supply is getting low
+
+      if Num_Waiting_AST_Servers < 2 then
+         Allocate_New_AST_Server;
+      end if;
+
+      --  No point in creating more if we have zillions waiting to
+      --  be serviced.
+
+      while AST_Service_Queue_Put - AST_Service_Queue_Get
+         > AST_Service_Queue_Limit
+      loop
+         delay 0.01;
+      end loop;
+
+      --  If no AST vector allocated, or the one we have is too short, then
+      --  allocate one of right size and initialize all entries except the
+      --  one we will use to unused. Note that the assignment automatically
+      --  frees the old allocated table if there is one.
+
+      if Attr_Ref.Vector = null
+        or else Attr_Ref.Vector'Length < Entryno
+      then
+         Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno);
+
+         for E in 1 .. Entryno loop
+            Attr_Ref.Vector (E).Descriptor.Entry_Point :=
+              Original_Descriptor_Ref.Entry_Point;
+            Attr_Ref.Vector (E).Descriptor.GP_Value :=
+              Attr_Ref.Vector (E)'Address;
+            Attr_Ref.Vector (E).Original_Descriptor_Ref :=
+              Original_Descriptor_Ref;
+            Attr_Ref.Vector (E).Taskid  := Taskid;
+            Attr_Ref.Vector (E).Entryno := E;
+         end loop;
+      end if;
+
+      return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access);
+   end Create_AST_Handler;
+
+   ----------------------------
+   -- Expand_AST_Packet_Pool --
+   ----------------------------
+
+   procedure Expand_AST_Packet_Pool
+     (Requested_Packets : Natural;
+      Actual_Number     : out Natural;
+      Total_Number      : out Natural)
+   is
+      pragma Unreferenced (Requested_Packets);
+   begin
+      --  The AST implementation of GNAT does not permit dynamic expansion
+      --  of the pool, so we simply add no entries and return the total. If
+      --  it is necessary to expand the allocation, then this package body
+      --  must be recompiled with a larger value for AST_Service_Queue_Size.
+
+      Actual_Number := 0;
+      Total_Number := AST_Service_Queue_Size;
+   end Expand_AST_Packet_Pool;
+
+   -----------------
+   -- Process_AST --
+   -----------------
+
+   procedure Process_AST (Param : Long_Integer) is
+
+      Handler_Data_Ptr : AST_Handler_Data_Ref;
+      --  This variable is set to the address of the descriptor through
+      --  which Process_AST is called. Since the descriptor is part of
+      --  an AST_Handler value, this is also the address of this value,
+      --  from which we can obtain the task and entry number information.
+
+      function To_Address is new Ada.Unchecked_Conversion
+        (ST.Task_Id, System.Task_Primitives.Task_Address);
+
+   begin
+      --  Move the contrived GP into place so Taskid and Entryno
+      --  become available, then restore the true GP.
+
+      System.Machine_Code.Asm
+        (Template => "mov %0 = r1",
+         Outputs  => AST_Handler_Data_Ref'Asm_Output
+          ("=r", Handler_Data_Ptr),
+         Volatile => True);
+
+      System.Machine_Code.Asm
+        (Template => "ld8 r1 = %0;;",
+         Inputs => System.Address'Asm_Input
+           ("m", Handler_Data_Ptr.Original_Descriptor_Ref.GP_Value),
+         Volatile => True);
+
+      AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance'
+        (Taskid  => Handler_Data_Ptr.Taskid,
+         Entryno => Handler_Data_Ptr.Entryno,
+         Param   => Param);
+
+      --  OpenVMS Programming Concepts manual, chapter 8.2.3:
+      --  "Implicit synchronization can be achieved for data that is shared
+      --   for write by using only AST routines to write the data, since only
+      --   one AST can be running at any one time."
+
+      --  This subprogram runs at AST level so is guaranteed to be
+      --  called sequentially at a given access level.
+
+      AST_Service_Queue_Put := AST_Service_Queue_Put + 1;
+
+      --  Need to wake up processing task. If there is no waiting server
+      --  then we have temporarily run out, but things should still be
+      --  OK, since one of the active ones will eventually pick up the
+      --  service request queued in the AST_Service_Queue.
+
+      for J in 1 .. Num_AST_Servers loop
+         if Is_Waiting (J) then
+            Is_Waiting (J) := False;
+
+            --  Sleeps are handled by ASTs on VMS, so don't call Wakeup
+
+            STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J)));
+            exit;
+         end if;
+      end loop;
+   end Process_AST;
+
+begin
+   STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
+end System.AST_Handling;
Index: s-auxdec-vms-ia64.adb
===================================================================
--- s-auxdec-vms-ia64.adb	(revision 0)
+++ s-auxdec-vms-ia64.adb	(revision 0)
@@ -0,0 +1,576 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                       S Y S T E M . A U X _ D E C                        --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 1992-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/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the Itanium/VMS version.
+
+--  The Add,Clear_Interlocked subprograms are dubiously implmented due to
+--  the lack of a single bit sync_lock_test_and_set builtin.
+
+--  The "Retry" parameter is ignored due to the lack of retry builtins making
+--  the subprograms identical to the non-retry versions.
+
+pragma Style_Checks (All_Checks);
+--  Turn off alpha ordering check on subprograms, this unit is laid
+--  out to correspond to the declarations in the DEC 83 System unit.
+
+with Interfaces;
+package body System.Aux_DEC is
+
+   use type Interfaces.Unsigned_8;
+
+   ------------------------
+   -- Fetch_From_Address --
+   ------------------------
+
+   function Fetch_From_Address (A : Address) return Target is
+      type T_Ptr is access all Target;
+      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
+      Ptr : constant T_Ptr := To_T_Ptr (A);
+   begin
+      return Ptr.all;
+   end Fetch_From_Address;
+
+   -----------------------
+   -- Assign_To_Address --
+   -----------------------
+
+   procedure Assign_To_Address (A : Address; T : Target) is
+      type T_Ptr is access all Target;
+      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
+      Ptr : constant T_Ptr := To_T_Ptr (A);
+   begin
+      Ptr.all := T;
+   end Assign_To_Address;
+
+   -----------------------
+   -- Clear_Interlocked --
+   -----------------------
+
+   procedure Clear_Interlocked
+     (Bit       : in out Boolean;
+      Old_Value : out Boolean)
+   is
+      Clr_Bit : Boolean := Bit;
+      Old_Uns : Interfaces.Unsigned_8;
+
+      function Sync_Lock_Test_And_Set
+        (Ptr   : Address;
+         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
+      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
+                     "__sync_lock_test_and_set_1");
+
+   begin
+      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
+      Bit := Clr_Bit;
+      Old_Value := Old_Uns /= 0;
+   end Clear_Interlocked;
+
+   procedure Clear_Interlocked
+     (Bit          : in out Boolean;
+      Old_Value    : out Boolean;
+      Retry_Count  : Natural;
+      Success_Flag : out Boolean)
+   is
+      pragma Unreferenced (Retry_Count);
+
+      Clr_Bit : Boolean := Bit;
+      Old_Uns : Interfaces.Unsigned_8;
+
+      function Sync_Lock_Test_And_Set
+        (Ptr   : Address;
+         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
+      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
+                     "__sync_lock_test_and_set_1");
+
+   begin
+      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
+      Bit := Clr_Bit;
+      Old_Value := Old_Uns /= 0;
+      Success_Flag := True;
+   end Clear_Interlocked;
+
+   ---------------------
+   -- Set_Interlocked --
+   ---------------------
+
+   procedure Set_Interlocked
+     (Bit       : in out Boolean;
+      Old_Value : out Boolean)
+   is
+      Set_Bit : Boolean := Bit;
+      Old_Uns : Interfaces.Unsigned_8;
+
+      function Sync_Lock_Test_And_Set
+        (Ptr   : Address;
+         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
+      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
+                     "__sync_lock_test_and_set_1");
+
+   begin
+      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
+      Bit := Set_Bit;
+      Old_Value := Old_Uns /= 0;
+   end Set_Interlocked;
+
+   procedure Set_Interlocked
+     (Bit          : in out Boolean;
+      Old_Value    : out Boolean;
+      Retry_Count  : Natural;
+      Success_Flag : out Boolean)
+   is
+      pragma Unreferenced (Retry_Count);
+
+      Set_Bit : Boolean := Bit;
+      Old_Uns : Interfaces.Unsigned_8;
+
+      function Sync_Lock_Test_And_Set
+        (Ptr   : Address;
+         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
+      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
+                     "__sync_lock_test_and_set_1");
+   begin
+      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
+      Bit := Set_Bit;
+      Old_Value := Old_Uns /= 0;
+      Success_Flag := True;
+   end Set_Interlocked;
+
+   ---------------------
+   -- Add_Interlocked --
+   ---------------------
+
+   procedure Add_Interlocked
+     (Addend : Short_Integer;
+      Augend : in out Aligned_Word;
+      Sign   : out Integer)
+   is
+      Overflowed : Boolean := False;
+      Former     : Aligned_Word;
+
+      function Sync_Fetch_And_Add
+        (Ptr   : Address;
+         Value : Short_Integer) return Short_Integer;
+      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");
+
+   begin
+      Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);
+
+      if Augend.Value < 0 then
+         Sign := -1;
+      elsif Augend.Value > 0 then
+         Sign := 1;
+      else
+         Sign := 0;
+      end if;
+
+      if Former.Value > 0 and then Augend.Value <= 0 then
+         Overflowed := True;
+      end if;
+
+      if Overflowed then
+         raise Constraint_Error;
+      end if;
+   end Add_Interlocked;
+
+   ----------------
+   -- Add_Atomic --
+   ----------------
+
+   procedure Add_Atomic
+     (To     : in out Aligned_Integer;
+      Amount : Integer)
+   is
+      procedure Sync_Add_And_Fetch
+        (Ptr   : Address;
+         Value : Integer);
+      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
+   begin
+      Sync_Add_And_Fetch (To.Value'Address, Amount);
+   end Add_Atomic;
+
+   procedure Add_Atomic
+     (To           : in out Aligned_Integer;
+      Amount       : Integer;
+      Retry_Count  : Natural;
+      Old_Value    : out Integer;
+      Success_Flag : out Boolean)
+   is
+      pragma Unreferenced (Retry_Count);
+
+      function Sync_Fetch_And_Add
+        (Ptr   : Address;
+         Value : Integer) return Integer;
+      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");
+
+   begin
+      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
+      Success_Flag := True;
+   end Add_Atomic;
+
+   procedure Add_Atomic
+     (To     : in out Aligned_Long_Integer;
+      Amount : Long_Integer)
+   is
+      procedure Sync_Add_And_Fetch
+        (Ptr   : Address;
+         Value : Long_Integer);
+      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");
+   begin
+      Sync_Add_And_Fetch (To.Value'Address, Amount);
+   end Add_Atomic;
+
+   procedure Add_Atomic
+     (To           : in out Aligned_Long_Integer;
+      Amount       : Long_Integer;
+      Retry_Count  : Natural;
+      Old_Value    : out Long_Integer;
+      Success_Flag : out Boolean)
+   is
+      pragma Unreferenced (Retry_Count);
+
+      function Sync_Fetch_And_Add
+        (Ptr   : Address;
+         Value : Long_Integer) return Long_Integer;
+      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8");
+      --  Why do we keep importing this over and over again???
+
+   begin
+      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
+      Success_Flag := True;
+   end Add_Atomic;
+
+   ----------------
+   -- And_Atomic --
+   ----------------
+
+   procedure And_Atomic
+     (To   : in out Aligned_Integer;
+      From : Integer)
+   is
+      procedure Sync_And_And_Fetch
+        (Ptr   : Address;
+         Value : Integer);
+      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");
+   begin
+      Sync_And_And_Fetch (To.Value'Address, From);
+   end And_Atomic;
+
+   procedure And_Atomic
+     (To           : in out Aligned_Integer;
+      From         : Integer;
+      Retry_Count  : Natural;
+      Old_Value    : out Integer;
+      Success_Flag : out Boolean)
+   is
+      pragma Unreferenced (Retry_Count);
+
+      function Sync_Fetch_And_And
+        (Ptr   : Address;
+         Value : Integer) return Integer;
+      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");
+
+   begin
+      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
+      Success_Flag := True;
+   end And_Atomic;
+
+   procedure And_Atomic
+     (To   : in out Aligned_Long_Integer;
+      From : Long_Integer)
+   is
+      procedure Sync_And_And_Fetch
+        (Ptr   : Address;
+         Value : Long_Integer);
+      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");
+   begin
+      Sync_And_And_Fetch (To.Value'Address, From);
+   end And_Atomic;
+
+   procedure And_Atomic
+     (To           : in out Aligned_Long_Integer;
+      From         : Long_Integer;
+      Retry_Count  : Natural;
+      Old_Value    : out Long_Integer;
+      Success_Flag : out Boolean)
+   is
+      pragma Unreferenced (Retry_Count);
+
+      function Sync_Fetch_And_And
+        (Ptr   : Address;
+         Value : Long_Integer) return Long_Integer;
+      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");
+
+   begin
+      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
+      Success_Flag := True;
+   end And_Atomic;
+
+   ---------------
+   -- Or_Atomic --
+   ---------------
+
+   procedure Or_Atomic
+     (To   : in out Aligned_Integer;
+      From : Integer)
+   is
+      procedure Sync_Or_And_Fetch
+        (Ptr   : Address;
+         Value : Integer);
+      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");
+
+   begin
+      Sync_Or_And_Fetch (To.Value'Address, From);
+   end Or_Atomic;
+
+   procedure Or_Atomic
+     (To           : in out Aligned_Integer;
+      From         : Integer;
+      Retry_Count  : Natural;
+      Old_Value    : out Integer;
+      Success_Flag : out Boolean)
+   is
+      pragma Unreferenced (Retry_Count);
+
+      function Sync_Fetch_And_Or
+        (Ptr   : Address;
+         Value : Integer) return Integer;
+      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");
+
+   begin
+      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
+      Success_Flag := True;
+   end Or_Atomic;
+
+   procedure Or_Atomic
+     (To   : in out Aligned_Long_Integer;
+      From : Long_Integer)
+   is
+      procedure Sync_Or_And_Fetch
+        (Ptr   : Address;
+         Value : Long_Integer);
+      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");
+   begin
+      Sync_Or_And_Fetch (To.Value'Address, From);
+   end Or_Atomic;
+
+   procedure Or_Atomic
+     (To           : in out Aligned_Long_Integer;
+      From         : Long_Integer;
+      Retry_Count  : Natural;
+      Old_Value    : out Long_Integer;
+      Success_Flag : out Boolean)
+   is
+      pragma Unreferenced (Retry_Count);
+
+      function Sync_Fetch_And_Or
+        (Ptr   : Address;
+         Value : Long_Integer) return Long_Integer;
+      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");
+
+   begin
+      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
+      Success_Flag := True;
+   end Or_Atomic;
+
+   ------------
+   -- Insqhi --
+   ------------
+
+   procedure Insqhi
+     (Item   : Address;
+      Header : Address;
+      Status : out Insq_Status) is
+
+      procedure SYS_PAL_INSQHIL
+        (STATUS : out Integer; Header : Address; ITEM : Address);
+      pragma Interface (External, SYS_PAL_INSQHIL);
+      pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",
+         (Integer, Address, Address),
+         (Value, Value, Value));
+
+      Istat : Integer;
+
+   begin
+      SYS_PAL_INSQHIL (Istat, Header, Item);
+
+      if Istat = 0 then
+         Status := OK_Not_First;
+      elsif Istat = 1 then
+         Status := OK_First;
+
+      else
+         --  This status is never returned on IVMS
+
+         Status := Fail_No_Lock;
+      end if;
+   end Insqhi;
+
+   ------------
+   -- Remqhi --
+   ------------
+
+   procedure Remqhi
+     (Header : Address;
+      Item   : out Address;
+      Status : out Remq_Status)
+   is
+      --  The removed item is returned in the second function return register,
+      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in
+      --  these registers, so inventing this odd looking record type makes that
+      --  all work.
+
+      type Remq is record
+         Status : Long_Integer;
+         Item   : Address;
+      end record;
+
+      procedure SYS_PAL_REMQHIL
+        (Remret : out Remq; Header : Address);
+      pragma Interface (External, SYS_PAL_REMQHIL);
+      pragma Import_Valued_Procedure
+        (SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",
+         (Remq, Address),
+         (Value, Value));
+
+      --  Following variables need documentation???
+
+      Rstat  : Long_Integer;
+      Remret : Remq;
+
+   begin
+      SYS_PAL_REMQHIL (Remret, Header);
+
+      Rstat := Remret.Status;
+      Item := Remret.Item;
+
+      if Rstat = 0 then
+         Status := Fail_Was_Empty;
+
+      elsif Rstat = 1 then
+         Status := OK_Not_Empty;
+
+      elsif Rstat = 2 then
+         Status := OK_Empty;
+
+      else
+         --  This status is never returned on IVMS
+
+         Status := Fail_No_Lock;
+      end if;
+
+   end Remqhi;
+
+   ------------
+   -- Insqti --
+   ------------
+
+   procedure Insqti
+     (Item   : Address;
+      Header : Address;
+      Status : out Insq_Status) is
+
+      procedure SYS_PAL_INSQTIL
+        (STATUS : out Integer; Header : Address; ITEM : Address);
+      pragma Interface (External, SYS_PAL_INSQTIL);
+      pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",
+         (Integer, Address, Address),
+         (Value, Value, Value));
+
+      Istat : Integer;
+
+   begin
+      SYS_PAL_INSQTIL (Istat, Header, Item);
+
+      if Istat = 0 then
+         Status := OK_Not_First;
+
+      elsif Istat = 1 then
+         Status := OK_First;
+
+      else
+         --  This status is never returned on IVMS
+
+         Status := Fail_No_Lock;
+      end if;
+   end Insqti;
+
+   ------------
+   -- Remqti --
+   ------------
+
+   procedure Remqti
+     (Header : Address;
+      Item   : out Address;
+      Status : out Remq_Status)
+   is
+      --  The removed item is returned in the second function return register,
+      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in
+      --  these registers, so inventing (where is rest of this comment???)
+
+      type Remq is record
+         Status : Long_Integer;
+         Item   : Address;
+      end record;
+
+      procedure SYS_PAL_REMQTIL
+        (Remret : out Remq; Header : Address);
+      pragma Interface (External, SYS_PAL_REMQTIL);
+      pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",
+         (Remq, Address),
+         (Value, Value));
+
+      Rstat  : Long_Integer;
+      Remret : Remq;
+
+   begin
+      SYS_PAL_REMQTIL (Remret, Header);
+
+      Rstat := Remret.Status;
+      Item := Remret.Item;
+
+      --  Wouldn't case be nicer here, and in previous similar cases ???
+
+      if Rstat = 0 then
+         Status := Fail_Was_Empty;
+
+      elsif Rstat = 1 then
+         Status := OK_Not_Empty;
+
+      elsif Rstat = 2 then
+         Status := OK_Empty;
+      else
+         --  This status is never returned on IVMS
+
+         Status := Fail_No_Lock;
+      end if;
+   end Remqti;
+
+end System.Aux_DEC;
Index: s-memory-vms_64.adb
===================================================================
--- s-memory-vms_64.adb	(revision 0)
+++ s-memory-vms_64.adb	(revision 0)
@@ -0,0 +1,230 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                         S Y S T E M . M E M O R Y                        --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 2001-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/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the VMS 64 bit implementation of this package
+
+--  This implementation assumes that the underlying malloc/free/realloc
+--  implementation is thread safe, and thus, no additional lock is required.
+--  Note that we still need to defer abort because on most systems, an
+--  asynchronous signal (as used for implementing asynchronous abort of
+--  task) cannot safely be handled while malloc is executing.
+
+--  If you are not using Ada constructs containing the "abort" keyword, then
+--  you can remove the calls to Abort_Defer.all and Abort_Undefer.all from
+--  this unit.
+
+pragma Compiler_Unit;
+
+with Ada.Exceptions;
+with System.Soft_Links;
+with System.Parameters;
+with System.CRTL;
+
+package body System.Memory is
+
+   use Ada.Exceptions;
+   use System.Soft_Links;
+
+   function c_malloc (Size : System.CRTL.size_t) return System.Address
+    renames System.CRTL.malloc;
+
+   procedure c_free (Ptr : System.Address)
+     renames System.CRTL.free;
+
+   function c_realloc
+     (Ptr : System.Address; Size : System.CRTL.size_t) return System.Address
+     renames System.CRTL.realloc;
+
+   Gnat_Heap_Size : Integer;
+   pragma Import (C, Gnat_Heap_Size, "__gl_heap_size");
+   --  Set by Feature logical GNAT$NO_MALLOC_64 and/or Binder switch -Hnn
+
+   -----------
+   -- Alloc --
+   -----------
+
+   function Alloc (Size : size_t) return System.Address is
+      Result      : System.Address;
+      Actual_Size : size_t := Size;
+
+   begin
+      if Gnat_Heap_Size = 32 then
+         return Alloc32 (Size);
+      end if;
+
+      if Size = size_t'Last then
+         Raise_Exception (Storage_Error'Identity, "object too large");
+      end if;
+
+      --  Change size from zero to non-zero. We still want a proper pointer
+      --  for the zero case because pointers to zero length objects have to
+      --  be distinct, but we can't just go ahead and allocate zero bytes,
+      --  since some malloc's return zero for a zero argument.
+
+      if Size = 0 then
+         Actual_Size := 1;
+      end if;
+
+      if Parameters.No_Abort then
+         Result := c_malloc (System.CRTL.size_t (Actual_Size));
+      else
+         Abort_Defer.all;
+         Result := c_malloc (System.CRTL.size_t (Actual_Size));
+         Abort_Undefer.all;
+      end if;
+
+      if Result = System.Null_Address then
+         Raise_Exception (Storage_Error'Identity, "heap exhausted");
+      end if;
+
+      return Result;
+   end Alloc;
+
+   -------------
+   -- Alloc32 --
+   -------------
+
+   function Alloc32 (Size : size_t) return System.Address is
+      Result      : System.Address;
+      Actual_Size : size_t := Size;
+
+   begin
+      if Size = size_t'Last then
+         Raise_Exception (Storage_Error'Identity, "object too large");
+      end if;
+
+      --  Change size from zero to non-zero. We still want a proper pointer
+      --  for the zero case because pointers to zero length objects have to
+      --  be distinct, but we can't just go ahead and allocate zero bytes,
+      --  since some malloc's return zero for a zero argument.
+
+      if Size = 0 then
+         Actual_Size := 1;
+      end if;
+
+      if Parameters.No_Abort then
+         Result := C_malloc32 (Actual_Size);
+      else
+         Abort_Defer.all;
+         Result := C_malloc32 (Actual_Size);
+         Abort_Undefer.all;
+      end if;
+
+      if Result = System.Null_Address then
+         Raise_Exception (Storage_Error'Identity, "heap exhausted");
+      end if;
+
+      return Result;
+   end Alloc32;
+
+   ----------
+   -- Free --
+   ----------
+
+   procedure Free (Ptr : System.Address) is
+   begin
+      if Parameters.No_Abort then
+         c_free (Ptr);
+      else
+         Abort_Defer.all;
+         c_free (Ptr);
+         Abort_Undefer.all;
+      end if;
+   end Free;
+
+   -------------
+   -- Realloc --
+   -------------
+
+   function Realloc
+     (Ptr  : System.Address;
+      Size : size_t)
+      return System.Address
+   is
+      Result      : System.Address;
+      Actual_Size : constant size_t := Size;
+
+   begin
+      if Gnat_Heap_Size = 32 then
+         return Realloc32 (Ptr, Size);
+      end if;
+
+      if Size = size_t'Last then
+         Raise_Exception (Storage_Error'Identity, "object too large");
+      end if;
+
+      if Parameters.No_Abort then
+         Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
+      else
+         Abort_Defer.all;
+         Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
+         Abort_Undefer.all;
+      end if;
+
+      if Result = System.Null_Address then
+         Raise_Exception (Storage_Error'Identity, "heap exhausted");
+      end if;
+
+      return Result;
+   end Realloc;
+
+   ---------------
+   -- Realloc32 --
+   ---------------
+
+   function Realloc32
+     (Ptr  : System.Address;
+      Size : size_t)
+      return System.Address
+   is
+      Result      : System.Address;
+      Actual_Size : constant size_t := Size;
+
+   begin
+      if Size = size_t'Last then
+         Raise_Exception (Storage_Error'Identity, "object too large");
+      end if;
+
+      if Parameters.No_Abort then
+         Result := C_realloc32 (Ptr, Actual_Size);
+      else
+         Abort_Defer.all;
+         Result := C_realloc32 (Ptr, Actual_Size);
+         Abort_Undefer.all;
+      end if;
+
+      if Result = System.Null_Address then
+         Raise_Exception (Storage_Error'Identity, "heap exhausted");
+      end if;
+
+      return Result;
+   end Realloc32;
+end System.Memory;
Index: s-memory-vms_64.ads
===================================================================
--- s-memory-vms_64.ads	(revision 0)
+++ s-memory-vms_64.ads	(revision 0)
@@ -0,0 +1,129 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                         S Y S T E M . M E M O R Y                        --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--          Copyright (C) 2001-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/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package provides the low level memory allocation/deallocation
+--  mechanisms used by GNAT for VMS 64 bit.
+
+--  To provide an alternate implementation, simply recompile the modified
+--  body of this package with gnatmake -u -a -g s-memory.adb and make sure
+--  that the ali and object files for this unit are found in the object
+--  search path.
+
+--  This unit may be used directly from an application program by providing
+--  an appropriate WITH, and the interface can be expected to remain stable.
+
+pragma Compiler_Unit;
+
+package System.Memory is
+   pragma Elaborate_Body;
+
+   type size_t is mod 2 ** Standard'Address_Size;
+   --  Note: the reason we redefine this here instead of using the
+   --  definition in Interfaces.C is that we do not want to drag in
+   --  all of Interfaces.C just because System.Memory is used.
+
+   function Alloc (Size : size_t) return System.Address;
+   --  This is the low level allocation routine. Given a size in storage
+   --  units, it returns the address of a maximally aligned block of
+   --  memory. The implementation of this routine is guaranteed to be
+   --  task safe, and also aborts are deferred if necessary.
+   --
+   --  If size_t is set to size_t'Last on entry, then a Storage_Error
+   --  exception is raised with a message "object too large".
+   --
+   --  If size_t is set to zero on entry, then a minimal (but non-zero)
+   --  size block is allocated.
+   --
+   --  Note: this is roughly equivalent to the standard C malloc call
+   --  with the additional semantics as described above.
+
+   function Alloc32 (Size : size_t) return System.Address;
+   --  Equivalent to Alloc except on VMS 64 bit where it invokes
+   --  32 bit malloc.
+
+   procedure Free (Ptr : System.Address);
+   --  This is the low level free routine. It frees a block previously
+   --  allocated with a call to Alloc. As in the case of Alloc, this
+   --  call is guaranteed task safe, and aborts are deferred.
+   --
+   --  Note: this is roughly equivalent to the standard C free call
+   --  with the additional semantics as described above.
+
+   function Realloc
+     (Ptr  : System.Address;
+      Size : size_t) return System.Address;
+   --  This is the low level reallocation routine. It takes an existing
+   --  block address returned by a previous call to Alloc or Realloc,
+   --  and reallocates the block. The size can either be increased or
+   --  decreased. If possible the reallocation is done in place, so that
+   --  the returned result is the same as the value of Ptr on entry.
+   --  However, it may be necessary to relocate the block to another
+   --  address, in which case the information is copied to the new
+   --  block, and the old block is freed. The implementation of this
+   --  routine is guaranteed to be task safe, and also aborts are
+   --  deferred as necessary.
+   --
+   --  If size_t is set to size_t'Last on entry, then a Storage_Error
+   --  exception is raised with a message "object too large".
+   --
+   --  If size_t is set to zero on entry, then a minimal (but non-zero)
+   --  size block is allocated.
+   --
+   --  Note: this is roughly equivalent to the standard C realloc call
+   --  with the additional semantics as described above.
+
+   function Realloc32
+     (Ptr  : System.Address;
+      Size : size_t) return System.Address;
+   --  Equivalent to Realloc except on VMS 64 bit where it invokes
+   --  32 bit realloc.
+
+private
+
+   --  The following names are used from the generated compiler code
+
+   pragma Export (C, Alloc,   "__gnat_malloc");
+   pragma Export (C, Alloc32, "__gnat_malloc32");
+   pragma Export (C, Free,    "__gnat_free");
+   pragma Export (C, Realloc, "__gnat_realloc");
+   pragma Export (C, Realloc32, "__gnat_realloc32");
+
+   function C_malloc32 (Size : size_t) return System.Address;
+   pragma Import (C, C_malloc32, "_malloc32");
+   --  An alias for malloc for allocating 32bit memory on 64bit VMS
+
+   function C_realloc32
+     (Ptr  : System.Address;
+      Size : size_t) return System.Address;
+   pragma Import (C, C_realloc32, "_realloc32");
+   --  An alias for realloc for allocating 32bit memory on 64bit VMS
+
+end System.Memory;
Index: s-osinte-vms-ia64.adb
===================================================================
--- s-osinte-vms-ia64.adb	(revision 0)
+++ s-osinte-vms-ia64.adb	(revision 0)
@@ -0,0 +1,58 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--                   S Y S T E M . O S _ I N T E R F A C E                  --
+--                                                                          --
+--                                  B o d y                                 --
+--                                                                          --
+--          Copyright (C) 2003-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.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is a OpenVMS/IA64 version of this package
+
+--  This package encapsulates all direct interfaces to OS services
+--  that are needed by children of System.
+
+pragma Polling (Off);
+--  Turn off polling, we do not want ATC polling to take place during
+--  tasking operations. It causes infinite loops and other problems.
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+   -----------------
+   -- sched_yield --
+   -----------------
+
+   function sched_yield return int is
+      procedure sched_yield_base;
+      pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP");
+
+   begin
+      sched_yield_base;
+      return 0;
+   end sched_yield;
+
+end System.OS_Interface;
Index: s-osinte-vms-ia64.ads
===================================================================
--- s-osinte-vms-ia64.ads	(revision 0)
+++ s-osinte-vms-ia64.ads	(revision 0)
@@ -0,0 +1,652 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
+--                                                                          --
+--                   S Y S T E M . O S _ I N T E R F A C E                  --
+--                                                                          --
+--                                  S p e c                                 --
+--                                                                          --
+--             Copyright (C) 1991-1994, Florida State University            --
+--          Copyright (C) 1995-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.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is a OpenVMS/IA64 version of this package
+
+--  This package encapsulates all direct interfaces to OS services
+--  that are needed by the tasking run-time (libgnarl).
+
+--  PLEASE DO NOT add any with-clauses to this package or remove the pragma
+--  Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+
+with Ada.Unchecked_Conversion;
+
+with System.Aux_DEC;
+
+package System.OS_Interface is
+   pragma Preelaborate;
+
+   pragma Linker_Options ("--for-linker=ia64$library:pthread$rtl.exe");
+   --  Link in the DEC threads library
+
+   --  pragma Linker_Options ("--for-linker=/threads_enable");
+   --  Enable upcalls and multiple kernel threads.
+
+   subtype int            is Interfaces.C.int;
+   subtype short          is Interfaces.C.short;
+   subtype long           is Interfaces.C.long;
+   subtype unsigned       is Interfaces.C.unsigned;
+   subtype unsigned_short is Interfaces.C.unsigned_short;
+   subtype unsigned_long  is Interfaces.C.unsigned_long;
+   subtype unsigned_char  is Interfaces.C.unsigned_char;
+   subtype plain_char     is Interfaces.C.plain_char;
+   subtype size_t         is Interfaces.C.size_t;
+
+   -----------------------------
+   -- Signals (Interrupt IDs) --
+   -----------------------------
+
+   --  Type signal has an arbitrary limit of 31
+
+   Max_Interrupt : constant := 31;
+   type Signal is new unsigned range 0 .. Max_Interrupt;
+   for Signal'Size use unsigned'Size;
+
+   type sigset_t is array (Signal) of Boolean;
+   pragma Pack (sigset_t);
+
+   --  Interrupt_Number_Type
+   --  Unsigned long integer denoting the number of an interrupt
+
+   subtype Interrupt_Number_Type is unsigned_long;
+
+   --  OpenVMS system services return values of type Cond_Value_Type
+
+   subtype Cond_Value_Type is unsigned_long;
+   subtype Short_Cond_Value_Type is unsigned_short;
+
+   type IO_Status_Block_Type is record
+      Status   : Short_Cond_Value_Type;
+      Count    : unsigned_short;
+      Dev_Info : unsigned_long;
+   end record;
+
+   type AST_Handler is access procedure (Param : Address);
+   pragma Convention (C, AST_Handler);
+   No_AST_Handler : constant AST_Handler := null;
+
+   CMB_M_READONLY  : constant := 16#00000001#;
+   CMB_M_WRITEONLY : constant := 16#00000002#;
+   AGN_M_READONLY  : constant := 16#00000001#;
+   AGN_M_WRITEONLY : constant := 16#00000002#;
+
+   IO_WRITEVBLK : constant := 48;  --  WRITE VIRTUAL BLOCK
+   IO_READVBLK  : constant := 49;  --  READ VIRTUAL BLOCK
+
+   ----------------
+   -- Sys_Assign --
+   ----------------
+   --
+   --  Assign I/O Channel
+   --
+   --  Status = returned status
+   --  Devnam = address  of  device  name  or  logical  name   string
+   --               descriptor
+   --  Chan   = address of word to receive channel number assigned
+   --  Acmode = access mode associated with channel
+   --  Mbxnam = address of mailbox logical name string descriptor, if
+   --               mailbox associated with device
+   --  Flags  = optional channel flags longword for specifying options
+   --           for the $ASSIGN operation
+   --
+
+   procedure Sys_Assign
+     (Status : out Cond_Value_Type;
+      Devnam : String;
+      Chan   : out unsigned_short;
+      Acmode : unsigned_short := 0;
+      Mbxnam : String := String'Null_Parameter;
+      Flags  : unsigned_long := 0);
+   pragma Interface (External, Sys_Assign);
+   pragma Import_Valued_Procedure
+     (Sys_Assign, "SYS$ASSIGN",
+      (Cond_Value_Type, String,         unsigned_short,
+       unsigned_short,  String,         unsigned_long),
+      (Value,           Descriptor (s), Reference,
+       Value,           Descriptor (s), Value),
+      Flags);
+
+   ----------------
+   -- Sys_Cantim --
+   ----------------
+   --
+   --  Cancel Timer
+   --
+   --  Status  = returned status
+   --  Reqidt  = ID of timer to be cancelled
+   --  Acmode  = Access mode
+   --
+   procedure Sys_Cantim
+     (Status : out Cond_Value_Type;
+      Reqidt : Address;
+      Acmode : unsigned);
+   pragma Interface (External, Sys_Cantim);
+   pragma Import_Valued_Procedure
+     (Sys_Cantim, "SYS$CANTIM",
+      (Cond_Value_Type, Address, unsigned),
+      (Value,           Value,   Value));
+
+   ----------------
+   -- Sys_Crembx --
+   ----------------
+   --
+   --  Create mailbox
+   --
+   --     Status  = returned status
+   --     Prmflg  = permanent flag
+   --     Chan    = channel
+   --     Maxmsg  = maximum message
+   --     Bufquo  = buufer quote
+   --     Promsk  = protection mast
+   --     Acmode  = access mode
+   --     Lognam  = logical name
+   --     Flags   = flags
+   --
+   procedure Sys_Crembx
+     (Status : out Cond_Value_Type;
+      Prmflg : unsigned_char;
+      Chan   : out unsigned_short;
+      Maxmsg : unsigned_long := 0;
+      Bufquo : unsigned_long := 0;
+      Promsk : unsigned_short := 0;
+      Acmode : unsigned_short := 0;
+      Lognam : String;
+      Flags  : unsigned_long := 0);
+   pragma Interface (External, Sys_Crembx);
+   pragma Import_Valued_Procedure
+     (Sys_Crembx, "SYS$CREMBX",
+      (Cond_Value_Type, unsigned_char,  unsigned_short,
+       unsigned_long,   unsigned_long,  unsigned_short,
+       unsigned_short,  String,         unsigned_long),
+      (Value,           Value,          Reference,
+       Value,           Value,          Value,
+       Value,           Descriptor (s), Value));
+
+   -------------
+   -- Sys_QIO --
+   -------------
+   --
+   --    Queue I/O
+   --
+   --     Status = Returned status of call
+   --     EFN    = event flag to be set when I/O completes
+   --     Chan   = channel
+   --     Func   = function
+   --     Iosb   = I/O status block
+   --     Astadr = system trap to be generated when I/O completes
+   --     Astprm = AST parameter
+   --     P1-6   = optional parameters
+
+   procedure Sys_QIO
+     (Status : out Cond_Value_Type;
+      EFN    : unsigned_long := 0;
+      Chan   : unsigned_short;
+      Func   : unsigned_long := 0;
+      Iosb   : out IO_Status_Block_Type;
+      Astadr : AST_Handler := No_AST_Handler;
+      Astprm : Address := Null_Address;
+      P1     : unsigned_long := 0;
+      P2     : unsigned_long := 0;
+      P3     : unsigned_long := 0;
+      P4     : unsigned_long := 0;
+      P5     : unsigned_long := 0;
+      P6     : unsigned_long := 0);
+
+   procedure Sys_QIO
+     (Status : out Cond_Value_Type;
+      EFN    : unsigned_long := 0;
+      Chan   : unsigned_short;
+      Func   : unsigned_long := 0;
+      Iosb   : Address := Null_Address;
+      Astadr : AST_Handler := No_AST_Handler;
+      Astprm : Address := Null_Address;
+      P1     : unsigned_long := 0;
+      P2     : unsigned_long := 0;
+      P3     : unsigned_long := 0;
+      P4     : unsigned_long := 0;
+      P5     : unsigned_long := 0;
+      P6     : unsigned_long := 0);
+
+   pragma Interface (External, Sys_QIO);
+   pragma Import_Valued_Procedure
+     (Sys_QIO, "SYS$QIO",
+      (Cond_Value_Type,      unsigned_long, unsigned_short, unsigned_long,
+       IO_Status_Block_Type, AST_Handler,   Address,
+       unsigned_long,        unsigned_long, unsigned_long,
+       unsigned_long,        unsigned_long, unsigned_long),
+      (Value,                Value,         Value,          Value,
+       Reference,            Value,         Value,
+       Value,                Value,         Value,
+       Value,                Value,         Value));
+
+   pragma Import_Valued_Procedure
+     (Sys_QIO, "SYS$QIO",
+      (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
+       Address,         AST_Handler,   Address,
+       unsigned_long,   unsigned_long, unsigned_long,
+       unsigned_long,   unsigned_long, unsigned_long),
+      (Value,           Value,         Value,          Value,
+       Value,           Value,         Value,
+       Value,           Value,         Value,
+       Value,           Value,         Value));
+
+   ----------------
+   -- Sys_Setimr --
+   ----------------
+   --
+   --    Set Timer
+   --
+   --     Status = Returned status of call
+   --     EFN    = event flag to be set when timer expires
+   --     Tim    = expiration time
+   --     AST    = system trap to be generated when timer expires
+   --     Redidt = returned ID of timer (e.g. to cancel timer)
+   --     Flags  = flags
+   --
+   procedure Sys_Setimr
+     (Status : out Cond_Value_Type;
+      EFN    : unsigned_long;
+      Tim    : Long_Integer;
+      AST    : AST_Handler;
+      Reqidt : Address;
+      Flags  : unsigned_long);
+   pragma Interface (External, Sys_Setimr);
+   pragma Import_Valued_Procedure
+     (Sys_Setimr, "SYS$SETIMR",
+      (Cond_Value_Type, unsigned_long,     Long_Integer,
+       AST_Handler,     Address,           unsigned_long),
+      (Value,           Value,             Reference,
+       Value,           Value,             Value));
+
+   Interrupt_ID_0   : constant  := 0;
+   Interrupt_ID_1   : constant  := 1;
+   Interrupt_ID_2   : constant  := 2;
+   Interrupt_ID_3   : constant  := 3;
+   Interrupt_ID_4   : constant  := 4;
+   Interrupt_ID_5   : constant  := 5;
+   Interrupt_ID_6   : constant  := 6;
+   Interrupt_ID_7   : constant  := 7;
+   Interrupt_ID_8   : constant  := 8;
+   Interrupt_ID_9   : constant  := 9;
+   Interrupt_ID_10  : constant  := 10;
+   Interrupt_ID_11  : constant  := 11;
+   Interrupt_ID_12  : constant  := 12;
+   Interrupt_ID_13  : constant  := 13;
+   Interrupt_ID_14  : constant  := 14;
+   Interrupt_ID_15  : constant  := 15;
+   Interrupt_ID_16  : constant  := 16;
+   Interrupt_ID_17  : constant  := 17;
+   Interrupt_ID_18  : constant  := 18;
+   Interrupt_ID_19  : constant  := 19;
+   Interrupt_ID_20  : constant  := 20;
+   Interrupt_ID_21  : constant  := 21;
+   Interrupt_ID_22  : constant  := 22;
+   Interrupt_ID_23  : constant  := 23;
+   Interrupt_ID_24  : constant  := 24;
+   Interrupt_ID_25  : constant  := 25;
+   Interrupt_ID_26  : constant  := 26;
+   Interrupt_ID_27  : constant  := 27;
+   Interrupt_ID_28  : constant  := 28;
+   Interrupt_ID_29  : constant  := 29;
+   Interrupt_ID_30  : constant  := 30;
+   Interrupt_ID_31  : constant  := 31;
+
+   -----------
+   -- Errno --
+   -----------
+
+   function errno return int;
+   pragma Import (C, errno, "__get_errno");
+
+   EINTR  : constant := 4;   --  Interrupted system call
+   EAGAIN : constant := 11;  --  No more processes
+   ENOMEM : constant := 12;  --  Not enough core
+
+   -------------------------
+   -- Priority Scheduling --
+   -------------------------
+
+   SCHED_FIFO  : constant := 1;
+   SCHED_RR    : constant := 2;
+   SCHED_OTHER : constant := 3;
+   SCHED_BG    : constant := 4;
+   SCHED_LFI   : constant := 5;
+   SCHED_LRR   : constant := 6;
+
+   -------------
+   -- Process --
+   -------------
+
+   type pid_t is private;
+
+   function kill (pid : pid_t; sig : Signal) return int;
+   pragma Import (C, kill);
+
+   function getpid return pid_t;
+   pragma Import (C, getpid);
+
+   -------------
+   -- Threads --
+   -------------
+
+   type Thread_Body is access
+     function (arg : System.Address) return System.Address;
+   pragma Convention (C, Thread_Body);
+
+   function Thread_Body_Access is new
+     Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body);
+
+   type pthread_t           is private;
+   subtype Thread_Id        is pthread_t;
+
+   type pthread_mutex_t     is limited private;
+   type pthread_cond_t      is limited private;
+   type pthread_attr_t      is limited private;
+   type pthread_mutexattr_t is limited private;
+   type pthread_condattr_t  is limited private;
+   type pthread_key_t       is private;
+
+   PTHREAD_CREATE_JOINABLE     : constant := 0;
+   PTHREAD_CREATE_DETACHED     : constant := 1;
+
+   PTHREAD_CANCEL_DISABLE      : constant := 0;
+   PTHREAD_CANCEL_ENABLE       : constant := 1;
+
+   PTHREAD_CANCEL_DEFERRED     : constant := 0;
+   PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1;
+
+   --  Don't use ERRORCHECK mutexes, they don't work when a thread is not
+   --  the owner.  AST's, at least, unlock others threads mutexes. Even
+   --  if the error is ignored, they don't work.
+   PTHREAD_MUTEX_NORMAL_NP     : constant := 0;
+   PTHREAD_MUTEX_RECURSIVE_NP  : constant := 1;
+   PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2;
+
+   PTHREAD_INHERIT_SCHED       : constant := 0;
+   PTHREAD_EXPLICIT_SCHED      : constant := 1;
+
+   function pthread_cancel (thread : pthread_t) return int;
+   pragma Import (C, pthread_cancel, "PTHREAD_CANCEL");
+
+   procedure pthread_testcancel;
+   pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL");
+
+   function pthread_setcancelstate
+     (newstate : int; oldstate : access int) return int;
+   pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE");
+
+   function pthread_setcanceltype
+     (newtype : int; oldtype : access int) return int;
+   pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE");
+
+   -------------------------
+   -- POSIX.1c  Section 3 --
+   -------------------------
+
+   function pthread_lock_global_np return int;
+   pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP");
+
+   function pthread_unlock_global_np return int;
+   pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP");
+
+   --------------------------
+   -- POSIX.1c  Section 11 --
+   --------------------------
+
+   function pthread_mutexattr_init
+     (attr : access pthread_mutexattr_t) return int;
+   pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT");
+
+   function pthread_mutexattr_destroy
+     (attr : access pthread_mutexattr_t) return int;
+   pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY");
+
+   function pthread_mutexattr_settype_np
+     (attr      : access pthread_mutexattr_t;
+      mutextype : int) return int;
+   pragma Import (C, pthread_mutexattr_settype_np,
+                     "PTHREAD_MUTEXATTR_SETTYPE_NP");
+
+   function pthread_mutex_init
+     (mutex : access pthread_mutex_t;
+      attr  : access pthread_mutexattr_t) return int;
+   pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT");
+
+   function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+   pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY");
+
+   function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+   pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK");
+
+   function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+   pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK");
+
+   function pthread_condattr_init
+     (attr : access pthread_condattr_t) return int;
+   pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT");
+
+   function pthread_condattr_destroy
+     (attr : access pthread_condattr_t) return int;
+   pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY");
+
+   function pthread_cond_init
+     (cond : access pthread_cond_t;
+      attr : access pthread_condattr_t) return int;
+   pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT");
+
+   function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+   pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY");
+
+   function pthread_cond_signal (cond : access pthread_cond_t) return int;
+   pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL");
+
+   function pthread_cond_signal_int_np
+     (cond : access pthread_cond_t) return int;
+   pragma Import (C, pthread_cond_signal_int_np,
+                  "PTHREAD_COND_SIGNAL_INT_NP");
+
+   function pthread_cond_wait
+     (cond  : access pthread_cond_t;
+      mutex : access pthread_mutex_t) return int;
+   pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT");
+
+   --------------------------
+   -- POSIX.1c  Section 13 --
+   --------------------------
+
+   function pthread_mutexattr_setprotocol
+     (attr : access pthread_mutexattr_t; protocol : int) return int;
+   pragma Import (C, pthread_mutexattr_setprotocol,
+                     "PTHREAD_MUTEXATTR_SETPROTOCOL");
+
+   type struct_sched_param is record
+      sched_priority : int;  --  scheduling priority
+   end record;
+   for struct_sched_param'Size use 8*4;
+   pragma Convention (C, struct_sched_param);
+
+   function pthread_setschedparam
+     (thread : pthread_t;
+      policy : int;
+      param  : access struct_sched_param) return int;
+   pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM");
+
+   function pthread_attr_setscope
+     (attr            : access pthread_attr_t;
+      contentionscope : int) return int;
+   pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE");
+
+   function pthread_attr_setinheritsched
+     (attr            : access pthread_attr_t;
+      inheritsched : int) return int;
+   pragma Import (C, pthread_attr_setinheritsched,
+                     "PTHREAD_ATTR_SETINHERITSCHED");
+
+   function pthread_attr_setschedpolicy
+     (attr : access pthread_attr_t; policy : int) return int;
+   pragma Import (C, pthread_attr_setschedpolicy,
+                     "PTHREAD_ATTR_SETSCHEDPOLICY");
+
+   function pthread_attr_setschedparam
+     (attr        : access pthread_attr_t;
+      sched_param : int) return int;
+   pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM");
+
+   function sched_yield return int;
+
+   --------------------------
+   -- P1003.1c  Section 16 --
+   --------------------------
+
+   function pthread_attr_init (attributes : access pthread_attr_t) return int;
+   pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT");
+
+   function pthread_attr_destroy
+     (attributes : access pthread_attr_t) return int;
+   pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY");
+
+   function pthread_attr_setdetachstate
+     (attr        : access pthread_attr_t;
+      detachstate : int) return int;
+   pragma Import (C, pthread_attr_setdetachstate,
+                     "PTHREAD_ATTR_SETDETACHSTATE");
+
+   function pthread_attr_setstacksize
+     (attr      : access pthread_attr_t;
+      stacksize : size_t) return int;
+   pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE");
+
+   function pthread_create
+     (thread        : access pthread_t;
+      attributes    : access pthread_attr_t;
+      start_routine : Thread_Body;
+      arg           : System.Address) return int;
+   pragma Import (C, pthread_create, "PTHREAD_CREATE");
+
+   procedure pthread_exit (status : System.Address);
+   pragma Import (C, pthread_exit, "PTHREAD_EXIT");
+
+   function pthread_self return pthread_t;
+   pragma Import (C, pthread_self, "PTHREAD_SELF");
+   --  ??? This can be inlined, see pthread.h
+
+   --------------------------
+   -- POSIX.1c  Section 17 --
+   --------------------------
+
+   function pthread_setspecific
+     (key   : pthread_key_t;
+      value : System.Address) return  int;
+   pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC");
+
+   function pthread_getspecific (key : pthread_key_t) return System.Address;
+   pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC");
+
+   type destructor_pointer is access procedure (arg : System.Address);
+   pragma Convention (C, destructor_pointer);
+
+   function pthread_key_create
+     (key        : access pthread_key_t;
+      destructor : destructor_pointer) return int;
+   pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE");
+
+private
+
+   type pid_t is new int;
+
+   type pthreadLongAddr_p is mod 2 ** Long_Integer'Size;
+
+   type pthreadLongAddr_t is mod 2 ** Long_Integer'Size;
+   type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size;
+
+   type pthreadLongString_t is mod 2 ** Long_Integer'Size;
+
+   type pthreadLongUint_t is mod 2 ** Long_Integer'Size;
+   type pthreadLongUint_array is array (Natural range <>)
+     of pthreadLongUint_t;
+
+   type pthread_t is mod 2 ** Long_Integer'Size;
+
+   type pthread_cond_t is record
+      state    : unsigned;
+      valid    : unsigned;
+      name     : pthreadLongString_t;
+      arg      : unsigned;
+      sequence : unsigned;
+      block    : pthreadLongAddr_t_ptr;
+   end record;
+   for pthread_cond_t'Size use 8*32;
+   pragma Convention (C, pthread_cond_t);
+
+   type pthread_attr_t is record
+      valid    : long;
+      name     : pthreadLongString_t;
+      arg      : pthreadLongUint_t;
+      reserved : pthreadLongUint_array (0 .. 18);
+   end record;
+   for pthread_attr_t'Size use 8*176;
+   pragma Convention (C, pthread_attr_t);
+
+   type pthread_mutex_t is record
+      lock     : unsigned;
+      valid    : unsigned;
+      name     : pthreadLongString_t;
+      arg      : unsigned;
+      sequence : unsigned;
+      block    : pthreadLongAddr_p;
+      owner    : unsigned;
+      depth    : unsigned;
+   end record;
+   for pthread_mutex_t'Size use 8*40;
+   pragma Convention (C, pthread_mutex_t);
+
+   type pthread_mutexattr_t is record
+      valid    : long;
+      reserved : pthreadLongUint_array (0 .. 14);
+   end record;
+   for pthread_mutexattr_t'Size use 8*128;
+   pragma Convention (C, pthread_mutexattr_t);
+
+   type pthread_condattr_t is record
+      valid    : long;
+      reserved : pthreadLongUint_array (0 .. 12);
+   end record;
+   for pthread_condattr_t'Size use 8*112;
+   pragma Convention (C, pthread_condattr_t);
+
+   type pthread_key_t is new unsigned;
+
+   pragma Inline (pthread_self);
+
+end System.OS_Interface;
Index: s-tasdeb-vms.adb
===================================================================
--- s-tasdeb-vms.adb	(revision 0)
+++ s-tasdeb-vms.adb	(revision 0)
@@ -0,0 +1,2158 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                  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;