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-2009, 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 uses gettimeofday and select 33-- This file is suitable for Solaris (32 and 64 bits). 34 35package body System.OS_Primitives is 36 37 -- ??? These definitions are duplicated from System.OS_Interface 38 -- because we don't want to depend on any package. Consider removing 39 -- these declarations in System.OS_Interface and move these ones in 40 -- the spec. 41 42 type struct_timeval is record 43 tv_sec : Long_Integer; 44 tv_usec : Long_Integer; 45 end record; 46 pragma Convention (C, struct_timeval); 47 48 procedure gettimeofday 49 (tv : not null access struct_timeval; 50 tz : Address := Null_Address); 51 pragma Import (C, gettimeofday, "gettimeofday"); 52 53 procedure C_select 54 (n : Integer := 0; 55 readfds, 56 writefds, 57 exceptfds : Address := Null_Address; 58 timeout : not null access struct_timeval); 59 pragma Import (C, C_select, "select"); 60 61 ----------- 62 -- Clock -- 63 ----------- 64 65 function Clock return Duration is 66 TV : aliased struct_timeval; 67 68 begin 69 gettimeofday (TV'Access); 70 return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; 71 end Clock; 72 73 --------------------- 74 -- Monotonic_Clock -- 75 --------------------- 76 77 function Monotonic_Clock return Duration renames Clock; 78 79 ----------------- 80 -- Timed_Delay -- 81 ----------------- 82 83 procedure Timed_Delay 84 (Time : Duration; 85 Mode : Integer) 86 is 87 Rel_Time : Duration; 88 Abs_Time : Duration; 89 Base_Time : constant Duration := Clock; 90 Check_Time : Duration := Base_Time; 91 timeval : aliased struct_timeval; 92 93 begin 94 if Mode = Relative then 95 Rel_Time := Time; 96 Abs_Time := Time + Check_Time; 97 else 98 Rel_Time := Time - Check_Time; 99 Abs_Time := Time; 100 end if; 101 102 if Rel_Time > 0.0 then 103 loop 104 timeval.tv_sec := Long_Integer (Rel_Time); 105 106 if Duration (timeval.tv_sec) > Rel_Time then 107 timeval.tv_sec := timeval.tv_sec - 1; 108 end if; 109 110 timeval.tv_usec := 111 Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); 112 113 C_select (timeout => timeval'Unchecked_Access); 114 Check_Time := Clock; 115 116 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; 117 118 Rel_Time := Abs_Time - Check_Time; 119 end loop; 120 end if; 121 end Timed_Delay; 122 123 ---------------- 124 -- Initialize -- 125 ---------------- 126 127 procedure Initialize is 128 begin 129 null; 130 end Initialize; 131 132end System.OS_Primitives; 133