Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/s-osprim__posix2008.adb @ 131:84e7813d76e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
4 -- -- 4 -- --
5 -- S Y S T E M . O S _ P R I M I T I V E S -- 5 -- S Y S T E M . O S _ P R I M I T I V E S --
6 -- -- 6 -- --
7 -- B o d y -- 7 -- B o d y --
8 -- -- 8 -- --
9 -- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- 9 -- Copyright (C) 1998-2018, Free Software Foundation, Inc. --
10 -- -- 10 -- --
11 -- GNARL is free software; you can redistribute it and/or modify it under -- 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- -- 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- -- 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- -- 14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
30 ------------------------------------------------------------------------------ 30 ------------------------------------------------------------------------------
31 31
32 -- This version is for POSIX.1-2008-like operating systems 32 -- This version is for POSIX.1-2008-like operating systems
33 33
34 with System.CRTL; 34 with System.CRTL;
35 with System.OS_Constants;
35 package body System.OS_Primitives is 36 package body System.OS_Primitives is
37
38 subtype int is System.CRTL.int;
36 39
37 -- ??? These definitions are duplicated from System.OS_Interface because 40 -- ??? These definitions are duplicated from System.OS_Interface because
38 -- we don't want to depend on any package. Consider removing these 41 -- we don't want to depend on any package. Consider removing these
39 -- declarations in System.OS_Interface and move these ones to the spec. 42 -- declarations in System.OS_Interface and move these ones to the spec.
40 43
52 ----------- 55 -----------
53 -- Clock -- 56 -- Clock --
54 ----------- 57 -----------
55 58
56 function Clock return Duration is 59 function Clock return Duration is
60 TS : aliased timespec;
61 Result : int;
57 62
58 type timeval is array (1 .. 3) of Long_Integer; 63 type clockid_t is new int;
59 -- The timeval array is sized to contain Long_Long_Integer sec and 64 CLOCK_REALTIME : constant clockid_t :=
60 -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then 65 System.OS_Constants.CLOCK_REALTIME;
61 -- it will be overly large but that will not effect the implementation
62 -- since it is not accessed directly.
63 66
64 procedure timeval_to_duration 67 function clock_gettime
65 (T : not null access timeval; 68 (clock_id : clockid_t;
66 sec : not null access Long_Long_Integer; 69 tp : access timespec) return int;
67 usec : not null access Long_Integer); 70 pragma Import (C, clock_gettime, "clock_gettime");
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 71
82 begin 72 begin
83 -- The return codes for gettimeofday are as follows (from man pages): 73 Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
84 -- EPERM settimeofday is called by someone other than the superuser 74 pragma Assert (Result = 0);
85 -- EINVAL Timezone (or something else) is invalid 75 return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
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; 76 end Clock;
95 77
96 ----------------- 78 -----------------
97 -- To_Timespec -- 79 -- To_Timespec --
98 ----------------- 80 -----------------
125 ----------------- 107 -----------------
126 108
127 procedure Timed_Delay 109 procedure Timed_Delay
128 (Time : Duration; 110 (Time : Duration;
129 Mode : Integer) 111 Mode : Integer)
130 is 112 is separate;
131 Request : aliased timespec;
132 Remaind : aliased timespec;
133 Rel_Time : Duration;
134 Abs_Time : Duration;
135 Base_Time : constant Duration := Clock;
136 Check_Time : Duration := Base_Time;
137
138 Result : Integer;
139 pragma Unreferenced (Result);
140
141 begin
142 if Mode = Relative then
143 Rel_Time := Time;
144 Abs_Time := Time + Check_Time;
145 else
146 Rel_Time := Time - Check_Time;
147 Abs_Time := Time;
148 end if;
149
150 if Rel_Time > 0.0 then
151 loop
152 Request := To_Timespec (Rel_Time);
153 Result := nanosleep (Request'Access, Remaind'Access);
154 Check_Time := Clock;
155
156 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
157
158 Rel_Time := Abs_Time - Check_Time;
159 end loop;
160 end if;
161 end Timed_Delay;
162 113
163 ---------------- 114 ----------------
164 -- Initialize -- 115 -- Initialize --
165 ---------------- 116 ----------------
166 117