------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
-- --
|
-- --
|
-- S Y S T E M . O S _ P R I M I T I V E S --
|
-- S Y S T E M . O S _ P R I M I T I V E S --
|
-- --
|
-- --
|
-- B o d y --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
|
-- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
|
-- --
|
-- --
|
-- GNARL is free software; you can redistribute it and/or modify it under --
|
-- GNARL 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- --
|
-- 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- --
|
-- 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- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
-- --
|
-- --
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
-- version 3.1, as published by the Free Software Foundation. --
|
-- version 3.1, as published by the Free Software Foundation. --
|
-- --
|
-- --
|
-- You should have received a copy of the GNU General Public License and --
|
-- 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; --
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
-- <http://www.gnu.org/licenses/>. --
|
-- <http://www.gnu.org/licenses/>. --
|
-- --
|
-- --
|
-- GNARL was developed by the GNARL team at Florida State University. --
|
-- GNARL was developed by the GNARL team at Florida State University. --
|
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
-- This is the OpenVMS/Alpha version of this file
|
-- This is the OpenVMS/Alpha version of this file
|
|
|
with System.Aux_DEC;
|
with System.Aux_DEC;
|
|
|
package body System.OS_Primitives is
|
package body System.OS_Primitives is
|
|
|
--------------------------------------
|
--------------------------------------
|
-- Local functions and declarations --
|
-- Local functions and declarations --
|
--------------------------------------
|
--------------------------------------
|
|
|
function Get_GMToff return Integer;
|
function Get_GMToff return Integer;
|
pragma Import (C, Get_GMToff, "get_gmtoff");
|
pragma Import (C, Get_GMToff, "get_gmtoff");
|
-- Get the offset from GMT for this timezone
|
-- Get the offset from GMT for this timezone
|
|
|
function VMS_Epoch_Offset return Long_Integer;
|
function VMS_Epoch_Offset return Long_Integer;
|
pragma Inline (VMS_Epoch_Offset);
|
pragma Inline (VMS_Epoch_Offset);
|
-- The offset between the Unix Epoch and the VMS Epoch
|
-- The offset between the Unix Epoch and the VMS Epoch
|
|
|
subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword;
|
subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword;
|
-- Condition Value return type
|
-- Condition Value return type
|
|
|
----------------------
|
----------------------
|
-- VMS_Epoch_Offset --
|
-- VMS_Epoch_Offset --
|
----------------------
|
----------------------
|
|
|
function VMS_Epoch_Offset return Long_Integer is
|
function VMS_Epoch_Offset return Long_Integer is
|
begin
|
begin
|
return 10_000_000 * (3_506_716_800 + Long_Integer (Get_GMToff));
|
return 10_000_000 * (3_506_716_800 + Long_Integer (Get_GMToff));
|
end VMS_Epoch_Offset;
|
end VMS_Epoch_Offset;
|
|
|
----------------
|
----------------
|
-- Sys_Schdwk --
|
-- Sys_Schdwk --
|
----------------
|
----------------
|
--
|
--
|
-- Schedule Wakeup
|
-- Schedule Wakeup
|
--
|
--
|
-- status = returned status
|
-- status = returned status
|
-- pidadr = address of process id to be woken up
|
-- pidadr = address of process id to be woken up
|
-- prcnam = name of process to be woken up
|
-- prcnam = name of process to be woken up
|
-- daytim = time to wake up
|
-- daytim = time to wake up
|
-- reptim = repetition interval of wakeup calls
|
-- reptim = repetition interval of wakeup calls
|
--
|
--
|
|
|
procedure Sys_Schdwk
|
procedure Sys_Schdwk
|
(
|
(
|
Status : out Cond_Value_Type;
|
Status : out Cond_Value_Type;
|
Pidadr : Address := Null_Address;
|
Pidadr : Address := Null_Address;
|
Prcnam : String := String'Null_Parameter;
|
Prcnam : String := String'Null_Parameter;
|
Daytim : Long_Integer;
|
Daytim : Long_Integer;
|
Reptim : Long_Integer := Long_Integer'Null_Parameter
|
Reptim : Long_Integer := Long_Integer'Null_Parameter
|
);
|
);
|
|
|
pragma Interface (External, Sys_Schdwk);
|
pragma Interface (External, Sys_Schdwk);
|
-- VMS system call to schedule a wakeup event
|
-- VMS system call to schedule a wakeup event
|
pragma Import_Valued_Procedure
|
pragma Import_Valued_Procedure
|
(Sys_Schdwk, "SYS$SCHDWK",
|
(Sys_Schdwk, "SYS$SCHDWK",
|
(Cond_Value_Type, Address, String, Long_Integer, Long_Integer),
|
(Cond_Value_Type, Address, String, Long_Integer, Long_Integer),
|
(Value, Value, Descriptor (S), Reference, Reference)
|
(Value, Value, Descriptor (S), Reference, Reference)
|
);
|
);
|
|
|
----------------
|
----------------
|
-- Sys_Gettim --
|
-- Sys_Gettim --
|
----------------
|
----------------
|
--
|
--
|
-- Get System Time
|
-- Get System Time
|
--
|
--
|
-- status = returned status
|
-- status = returned status
|
-- tim = current system time
|
-- tim = current system time
|
--
|
--
|
|
|
procedure Sys_Gettim
|
procedure Sys_Gettim
|
(
|
(
|
Status : out Cond_Value_Type;
|
Status : out Cond_Value_Type;
|
Tim : out OS_Time
|
Tim : out OS_Time
|
);
|
);
|
-- VMS system call to get the current system time
|
-- VMS system call to get the current system time
|
pragma Interface (External, Sys_Gettim);
|
pragma Interface (External, Sys_Gettim);
|
pragma Import_Valued_Procedure
|
pragma Import_Valued_Procedure
|
(Sys_Gettim, "SYS$GETTIM",
|
(Sys_Gettim, "SYS$GETTIM",
|
(Cond_Value_Type, OS_Time),
|
(Cond_Value_Type, OS_Time),
|
(Value, Reference)
|
(Value, Reference)
|
);
|
);
|
|
|
---------------
|
---------------
|
-- Sys_Hiber --
|
-- Sys_Hiber --
|
---------------
|
---------------
|
|
|
-- Hibernate (until woken up)
|
-- Hibernate (until woken up)
|
|
|
-- status = returned status
|
-- status = returned status
|
|
|
procedure Sys_Hiber (Status : out Cond_Value_Type);
|
procedure Sys_Hiber (Status : out Cond_Value_Type);
|
-- VMS system call to hibernate the current process
|
-- VMS system call to hibernate the current process
|
pragma Interface (External, Sys_Hiber);
|
pragma Interface (External, Sys_Hiber);
|
pragma Import_Valued_Procedure
|
pragma Import_Valued_Procedure
|
(Sys_Hiber, "SYS$HIBER",
|
(Sys_Hiber, "SYS$HIBER",
|
(Cond_Value_Type),
|
(Cond_Value_Type),
|
(Value)
|
(Value)
|
);
|
);
|
|
|
-----------
|
-----------
|
-- Clock --
|
-- Clock --
|
-----------
|
-----------
|
|
|
function OS_Clock return OS_Time is
|
function OS_Clock return OS_Time is
|
Status : Cond_Value_Type;
|
Status : Cond_Value_Type;
|
T : OS_Time;
|
T : OS_Time;
|
begin
|
begin
|
Sys_Gettim (Status, T);
|
Sys_Gettim (Status, T);
|
return (T);
|
return (T);
|
end OS_Clock;
|
end OS_Clock;
|
|
|
-----------
|
-----------
|
-- Clock --
|
-- Clock --
|
-----------
|
-----------
|
|
|
function Clock return Duration is
|
function Clock return Duration is
|
begin
|
begin
|
return To_Duration (OS_Clock, Absolute_Calendar);
|
return To_Duration (OS_Clock, Absolute_Calendar);
|
end Clock;
|
end Clock;
|
|
|
----------------
|
----------------
|
-- Initialize --
|
-- Initialize --
|
----------------
|
----------------
|
|
|
procedure Initialize is
|
procedure Initialize is
|
begin
|
begin
|
null;
|
null;
|
end Initialize;
|
end Initialize;
|
|
|
---------------------
|
---------------------
|
-- Monotonic_Clock --
|
-- Monotonic_Clock --
|
---------------------
|
---------------------
|
|
|
function Monotonic_Clock return Duration renames Clock;
|
function Monotonic_Clock return Duration renames Clock;
|
|
|
-----------------
|
-----------------
|
-- Timed_Delay --
|
-- Timed_Delay --
|
-----------------
|
-----------------
|
|
|
procedure Timed_Delay
|
procedure Timed_Delay
|
(Time : Duration;
|
(Time : Duration;
|
Mode : Integer)
|
Mode : Integer)
|
is
|
is
|
Sleep_Time : OS_Time;
|
Sleep_Time : OS_Time;
|
Status : Cond_Value_Type;
|
Status : Cond_Value_Type;
|
pragma Unreferenced (Status);
|
pragma Unreferenced (Status);
|
|
|
begin
|
begin
|
Sleep_Time := To_OS_Time (Time, Mode);
|
Sleep_Time := To_OS_Time (Time, Mode);
|
Sys_Schdwk (Status => Status, Daytim => Sleep_Time);
|
Sys_Schdwk (Status => Status, Daytim => Sleep_Time);
|
Sys_Hiber (Status);
|
Sys_Hiber (Status);
|
end Timed_Delay;
|
end Timed_Delay;
|
|
|
-----------------
|
-----------------
|
-- To_Duration --
|
-- To_Duration --
|
-----------------
|
-----------------
|
|
|
function To_Duration (T : OS_Time; Mode : Integer) return Duration is
|
function To_Duration (T : OS_Time; Mode : Integer) return Duration is
|
pragma Warnings (Off, Mode);
|
pragma Warnings (Off, Mode);
|
begin
|
begin
|
return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100;
|
return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100;
|
end To_Duration;
|
end To_Duration;
|
|
|
----------------
|
----------------
|
-- To_OS_Time --
|
-- To_OS_Time --
|
----------------
|
----------------
|
|
|
function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is
|
function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is
|
begin
|
begin
|
if Mode = Relative then
|
if Mode = Relative then
|
return -(Long_Integer'Integer_Value (D) / 100);
|
return -(Long_Integer'Integer_Value (D) / 100);
|
else
|
else
|
return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset;
|
return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset;
|
end if;
|
end if;
|
end To_OS_Time;
|
end To_OS_Time;
|
|
|
end System.OS_Primitives;
|
end System.OS_Primitives;
|
|
|