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