1------------------------------------------------------------------------------ 2-- -- 3-- GNAT 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-- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNARL is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is the OpenVMS/Alpha version of this file 33 34with System.Aux_DEC; 35 36package body System.OS_Primitives is 37 38 -------------------------------------- 39 -- Local functions and declarations -- 40 -------------------------------------- 41 42 function Get_GMToff return Integer; 43 pragma Import (C, Get_GMToff, "get_gmtoff"); 44 -- Get the offset from GMT for this timezone 45 46 function VMS_Epoch_Offset return Long_Integer; 47 pragma Inline (VMS_Epoch_Offset); 48 -- The offset between the Unix Epoch and the VMS Epoch 49 50 subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword; 51 -- Condition Value return type 52 53 ---------------------- 54 -- VMS_Epoch_Offset -- 55 ---------------------- 56 57 function VMS_Epoch_Offset return Long_Integer is 58 begin 59 return 10_000_000 * (3_506_716_800 + Long_Integer (Get_GMToff)); 60 end VMS_Epoch_Offset; 61 62 ---------------- 63 -- Sys_Schdwk -- 64 ---------------- 65 -- 66 -- Schedule Wakeup 67 -- 68 -- status = returned status 69 -- pidadr = address of process id to be woken up 70 -- prcnam = name of process to be woken up 71 -- daytim = time to wake up 72 -- reptim = repetition interval of wakeup calls 73 -- 74 75 procedure Sys_Schdwk 76 ( 77 Status : out Cond_Value_Type; 78 Pidadr : Address := Null_Address; 79 Prcnam : String := String'Null_Parameter; 80 Daytim : Long_Integer; 81 Reptim : Long_Integer := Long_Integer'Null_Parameter 82 ); 83 84 pragma Import (External, Sys_Schdwk); 85 -- VMS system call to schedule a wakeup event 86 pragma Import_Valued_Procedure 87 (Sys_Schdwk, "SYS$SCHDWK", 88 (Cond_Value_Type, Address, String, Long_Integer, Long_Integer), 89 (Value, Value, Descriptor (S), Reference, Reference) 90 ); 91 92 ---------------- 93 -- Sys_Gettim -- 94 ---------------- 95 -- 96 -- Get System Time 97 -- 98 -- status = returned status 99 -- tim = current system time 100 -- 101 102 procedure Sys_Gettim 103 ( 104 Status : out Cond_Value_Type; 105 Tim : out OS_Time 106 ); 107 -- VMS system call to get the current system time 108 pragma Import (External, Sys_Gettim); 109 pragma Import_Valued_Procedure 110 (Sys_Gettim, "SYS$GETTIM", 111 (Cond_Value_Type, OS_Time), 112 (Value, Reference) 113 ); 114 115 --------------- 116 -- Sys_Hiber -- 117 --------------- 118 119 -- Hibernate (until woken up) 120 121 -- status = returned status 122 123 procedure Sys_Hiber (Status : out Cond_Value_Type); 124 -- VMS system call to hibernate the current process 125 pragma Import (External, Sys_Hiber); 126 pragma Import_Valued_Procedure 127 (Sys_Hiber, "SYS$HIBER", 128 (Cond_Value_Type), 129 (Value) 130 ); 131 132 ----------- 133 -- Clock -- 134 ----------- 135 136 function OS_Clock return OS_Time is 137 Status : Cond_Value_Type; 138 T : OS_Time; 139 begin 140 Sys_Gettim (Status, T); 141 return (T); 142 end OS_Clock; 143 144 ----------- 145 -- Clock -- 146 ----------- 147 148 function Clock return Duration is 149 begin 150 return To_Duration (OS_Clock, Absolute_Calendar); 151 end Clock; 152 153 ---------------- 154 -- Initialize -- 155 ---------------- 156 157 procedure Initialize is 158 begin 159 null; 160 end Initialize; 161 162 --------------------- 163 -- Monotonic_Clock -- 164 --------------------- 165 166 function Monotonic_Clock return Duration renames Clock; 167 168 ----------------- 169 -- Timed_Delay -- 170 ----------------- 171 172 procedure Timed_Delay 173 (Time : Duration; 174 Mode : Integer) 175 is 176 Sleep_Time : OS_Time; 177 Status : Cond_Value_Type; 178 pragma Unreferenced (Status); 179 180 begin 181 Sleep_Time := To_OS_Time (Time, Mode); 182 Sys_Schdwk (Status => Status, Daytim => Sleep_Time); 183 Sys_Hiber (Status); 184 end Timed_Delay; 185 186 ----------------- 187 -- To_Duration -- 188 ----------------- 189 190 function To_Duration (T : OS_Time; Mode : Integer) return Duration is 191 pragma Warnings (Off, Mode); 192 begin 193 return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100; 194 end To_Duration; 195 196 ---------------- 197 -- To_OS_Time -- 198 ---------------- 199 200 function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is 201 begin 202 if Mode = Relative then 203 return -(Long_Integer'Integer_Value (D) / 100); 204 else 205 return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset; 206 end if; 207 end To_OS_Time; 208 209end System.OS_Primitives; 210