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-2014, 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 version is for POSIX-like operating systems 33 34package body System.OS_Primitives is 35 36 -- ??? These definitions are duplicated from System.OS_Interface 37 -- because we don't want to depend on any package. Consider removing 38 -- these declarations in System.OS_Interface and move these ones in 39 -- the spec. 40 41 type time_t is new Long_Integer; 42 43 type timespec is record 44 tv_sec : time_t; 45 tv_nsec : Long_Integer; 46 end record; 47 pragma Convention (C, timespec); 48 49 function nanosleep (rqtp, rmtp : not null access timespec) return Integer; 50 pragma Import (C, nanosleep, "nanosleep"); 51 52 ----------- 53 -- Clock -- 54 ----------- 55 56 function Clock return Duration is 57 58 type timeval is array (1 .. 3) of Long_Integer; 59 -- The timeval array is sized to contain Long_Long_Integer sec and 60 -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then 61 -- it will be overly large but that will not effect the implementation 62 -- since it is not accessed directly. 63 64 procedure timeval_to_duration 65 (T : not null access timeval; 66 sec : not null access Long_Long_Integer; 67 usec : not null access Long_Integer); 68 pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); 69 70 Micro : constant := 10**6; 71 sec : aliased Long_Long_Integer; 72 usec : aliased Long_Integer; 73 TV : aliased timeval; 74 Result : Integer; 75 pragma Unreferenced (Result); 76 77 function gettimeofday 78 (Tv : access timeval; 79 Tz : System.Address := System.Null_Address) return Integer; 80 pragma Import (C, gettimeofday, "gettimeofday"); 81 82 begin 83 -- The return codes for gettimeofday are as follows (from man pages): 84 -- EPERM settimeofday is called by someone other than the superuser 85 -- EINVAL Timezone (or something else) is invalid 86 -- EFAULT One of tv or tz pointed outside accessible address space 87 88 -- None of these codes signal a potential clock skew, hence the return 89 -- value is never checked. 90 91 Result := gettimeofday (TV'Access, System.Null_Address); 92 timeval_to_duration (TV'Access, sec'Access, usec'Access); 93 return Duration (sec) + Duration (usec) / Micro; 94 end Clock; 95 96 --------------------- 97 -- Monotonic_Clock -- 98 --------------------- 99 100 function Monotonic_Clock return Duration renames Clock; 101 102 ----------------- 103 -- To_Timespec -- 104 ----------------- 105 106 function To_Timespec (D : Duration) return timespec; 107 108 function To_Timespec (D : Duration) return timespec is 109 S : time_t; 110 F : Duration; 111 112 begin 113 S := time_t (Long_Long_Integer (D)); 114 F := D - Duration (S); 115 116 -- If F has negative value due to a round-up, adjust for positive F 117 -- value. 118 119 if F < 0.0 then 120 S := S - 1; 121 F := F + 1.0; 122 end if; 123 124 return 125 timespec'(tv_sec => S, 126 tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); 127 end To_Timespec; 128 129 ----------------- 130 -- Timed_Delay -- 131 ----------------- 132 133 procedure Timed_Delay 134 (Time : Duration; 135 Mode : Integer) 136 is 137 Request : aliased timespec; 138 Remaind : aliased timespec; 139 Rel_Time : Duration; 140 Abs_Time : Duration; 141 Base_Time : constant Duration := Clock; 142 Check_Time : Duration := Base_Time; 143 144 Result : Integer; 145 pragma Unreferenced (Result); 146 147 begin 148 if Mode = Relative then 149 Rel_Time := Time; 150 Abs_Time := Time + Check_Time; 151 else 152 Rel_Time := Time - Check_Time; 153 Abs_Time := Time; 154 end if; 155 156 if Rel_Time > 0.0 then 157 loop 158 Request := To_Timespec (Rel_Time); 159 Result := nanosleep (Request'Access, Remaind'Access); 160 Check_Time := Clock; 161 162 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; 163 164 Rel_Time := Abs_Time - Check_Time; 165 end loop; 166 end if; 167 end Timed_Delay; 168 169 ---------------- 170 -- Initialize -- 171 ---------------- 172 173 procedure Initialize is 174 begin 175 null; 176 end Initialize; 177 178end System.OS_Primitives; 179