gcc/ada/5vosprim.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --                  S Y S T E M . O S _ P R I M I T I V E S                 --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1998-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University. It is --
  31 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  32 -- State University (http://www.gnat.com).                                  --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  This is the OpenVMS/Alpha version of this file
  37
  38 with System.Aux_DEC;
  39
  40 package body System.OS_Primitives is
  41
  42    --------------------------------------
  43    -- Local functions and declarations --
  44    --------------------------------------
  45
  46    function Get_GMToff return Integer;
  47    pragma Import (C, Get_GMToff, "get_gmtoff");
  48    --  Get the offset from GMT for this timezone
  49
  50    VMS_Epoch_Offset : constant Long_Integer :=
  51                         10_000_000 *
  52                           (3_506_716_800 + Long_Integer (Get_GMToff));
  53    --  The offset between the Unix Epoch and the VMS Epoch
  54
  55    subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword;
  56    --  Condition Value return type
  57
  58    ----------------
  59    -- Sys_Schdwk --
  60    ----------------
  61    --
  62    --  Schedule Wakeup
  63    --
  64    --  status = returned status
  65    --  pidadr = address of process id to be woken up
  66    --  prcnam = name of process to be woken up
  67    --  daytim = time to wake up
  68    --  reptim = repitition interval of wakeup calls
  69    --
  70
  71    procedure Sys_Schdwk
  72      (
  73       Status : out Cond_Value_Type;
  74       Pidadr : in Address := Null_Address;
  75       Prcnam : in String := String'Null_Parameter;
  76       Daytim : in Long_Integer;
  77       Reptim : in Long_Integer := Long_Integer'Null_Parameter
  78      );
  79
  80    pragma Interface (External, Sys_Schdwk);
  81    --  VMS system call to schedule a wakeup event
  82    pragma Import_Valued_Procedure
  83      (Sys_Schdwk, "SYS$SCHDWK",
  84       (Cond_Value_Type, Address, String,         Long_Integer, Long_Integer),
  85       (Value,           Value,   Descriptor (S), Reference,    Reference)
  86      );
  87
  88    ----------------
  89    -- Sys_Gettim --
  90    ----------------
  91    --
  92    --  Get System Time
  93    --
  94    --  status = returned status
  95    --  tim    = current system time
  96    --
  97
  98    procedure Sys_Gettim
  99      (
 100       Status : out Cond_Value_Type;
 101       Tim    : out OS_Time
 102      );
 103    --  VMS system call to get the current system time
 104    pragma Interface (External, Sys_Gettim);
 105    pragma Import_Valued_Procedure
 106      (Sys_Gettim, "SYS$GETTIM",
 107       (Cond_Value_Type, OS_Time),
 108       (Value,           Reference)
 109      );
 110
 111    ---------------
 112    -- Sys_Hiber --
 113    ---------------
 114    --
 115    --  Hibernate (until woken up)
 116    --
 117    --  status = returned status
 118    --
 119
 120    procedure Sys_Hiber (Status : out Cond_Value_Type);
 121    --  VMS system call to hibernate the current process
 122    pragma Interface (External, Sys_Hiber);
 123    pragma Import_Valued_Procedure
 124      (Sys_Hiber, "SYS$HIBER",
 125       (Cond_Value_Type),
 126       (Value)
 127      );
 128
 129    -----------
 130    -- Clock --
 131    -----------
 132
 133    function OS_Clock return OS_Time is
 134       Status : Cond_Value_Type;
 135       T      : OS_Time;
 136    begin
 137       Sys_Gettim (Status, T);
 138       return (T);
 139    end OS_Clock;
 140
 141    -----------
 142    -- Clock --
 143    -----------
 144
 145    function Clock return Duration is
 146    begin
 147       return To_Duration (OS_Clock, Absolute_Calendar);
 148    end Clock;
 149
 150    ---------------------
 151    -- Monotonic_Clock --
 152    ---------------------
 153
 154    function Monotonic_Clock return Duration renames Clock;
 155
 156    -----------------
 157    -- Timed_Delay --
 158    -----------------
 159
 160    procedure Timed_Delay
 161      (Time : Duration;
 162       Mode : Integer)
 163    is
 164       Sleep_Time : OS_Time;
 165       Status     : Cond_Value_Type;
 166
 167    begin
 168       Sleep_Time := To_OS_Time (Time, Mode);
 169       Sys_Schdwk (Status => Status, Daytim => Sleep_Time);
 170       Sys_Hiber (Status);
 171    end Timed_Delay;
 172
 173    -----------------
 174    -- To_Duration --
 175    -----------------
 176
 177    function To_Duration (T : OS_Time; Mode : Integer) return Duration is
 178    begin
 179       return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100;
 180    end To_Duration;
 181
 182    ----------------
 183    -- To_OS_Time --
 184    ----------------
 185
 186    function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is
 187    begin
 188       if Mode = Relative then
 189          return -(Long_Integer'Integer_Value (D) / 100);
 190       else
 191          return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset;
 192       end if;
 193    end To_OS_Time;
 194
 195 end System.OS_Primitives;