+2017-10-20 Doug Rupp <rupp@adacore.com>
+
+ * libgnarl/s-osinte__linux.ads (Relative_Timed_Wait): Add variable
+ needed for using monotonic clock.
+ * libgnarl/s-taprop__linux.adb: Revert previous monotonic clock
+ changes.
+ * libgnarl/s-taprop__linux.adb, s-taprop__posix.adb: Unify and factor
+ out monotonic clock related functions body.
+ (Timed_Sleep, Timed_Delay, Montonic_Clock, RT_Resolution,
+ Compute_Deadline): Move to...
+ * libgnarl/s-tpopmo.adb: ... here. New separate package body.
+
+2017-10-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Is_Controlling_Limited_Procedure): Handle properly the
+ case where the controlling formal is an anonymous access to interface
+ type.
+ * exp_ch9.adb (Extract_Dispatching_Call): If controlling actual is an
+ access type, handle properly the the constructed dereference that
+ designates the object used in the rewritten synchronized call.
+ (Parameter_Block_Pack): If the type of the actual is by-copy, its
+ generated declaration in the parameter block does not need an
+ initialization even if the type is a null-excluding access type,
+ because it will be initialized with the value of the actual later on.
+ (Parameter_Block_Pack): Do not add controlling actual to parameter
+ block when its type is by-copy.
+
+2017-10-20 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch8.adb (Update_Use_Clause_Chain): Add sanity check to verify
+ scope stack traversal into the context clause.
+
2017-10-20 Bob Duff <duff@adacore.com>
* sinfo.ads: Fix a comment typo.
end if;
-- If the type of the dispatching object is an access type then return
- -- an explicit dereference.
+ -- an explicit dereference of a copy of the object, and note that
+ -- this is the controlling actual of the call.
if Is_Access_Type (Etype (Object)) then
- Object := Make_Explicit_Dereference (Sloc (N), Object);
+ Object :=
+ Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object));
Analyze (Object);
+ Set_Is_Controlling_Actual (Object);
end if;
end Extract_Dispatching_Call;
Object_Definition =>
New_Occurrence_Of (Etype (Formal), Loc)));
+ -- The object is initialized with an explicit assignment
+ -- later. Indicate that it does not need an initialization
+ -- to prevent spurious warnings if the type excludes null.
+
+ Set_No_Initialization (Last (Decls));
+
if Ekind (Formal) /= E_Out_Parameter then
-- Generate:
Expression => New_Copy_Tree (Actual)));
end if;
- -- Generate:
+ -- If the actual is not controlling, generate:
+
-- Jnn'unchecked_access
- Append_To (Params,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unchecked_Access,
- Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
+ -- and add it to aggegate for access to formals. Note that
+ -- the actual may be by-copy but still be a controlling actual
+ -- if it is an access to class-wide interface.
- Has_Param := True;
+ if not Is_Controlling_Actual (Actual) then
+ Append_To (Params,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unchecked_Access,
+ Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
+
+ Has_Param := True;
+ end if;
-- The controlling parameter is omitted
abstime : access timespec) return int;
pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
--------------------------
-- POSIX.1c Section 13 --
--------------------------
-- Turn off polling, we do not want ATC polling to take place during tasking
-- operations. It causes infinite loops and other problems.
-with Interfaces.C; use Interfaces;
-use type Interfaces.C.int;
-use type Interfaces.C.long;
+with Interfaces.C; use Interfaces; use type Interfaces.C.int;
with System.Task_Info;
with System.Tasking.Debug;
-- Constant to indicate that the thread identifier has not yet been
-- initialized.
- Base_Monotonic_Clock : Duration := 0.0;
-
--------------------
-- Local Packages --
--------------------
package body Specific is separate;
-- The body of this package is target specific
+ package Monotonic is
+
+ function Monotonic_Clock return Duration;
+ pragma Inline (Monotonic_Clock);
+ -- Returns "absolute" time, represented as an offset relative to "the
+ -- Epoch", which is Jan 1, 1970. This clock implementation is immune to
+ -- the system's clock changes.
+
+ function RT_Resolution return Duration;
+ pragma Inline (RT_Resolution);
+ -- Returns resolution of the underlying clock used to implement RT_Clock
+
+ procedure Timed_Sleep
+ (Self_ID : ST.Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean);
+ -- Combination of Sleep (above) and Timed_Delay
+
+ procedure Timed_Delay
+ (Self_ID : ST.Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes);
+ -- Implement the semantics of the delay statement.
+ -- The caller should be abort-deferred and should not hold any locks.
+
+ end Monotonic;
+
+ package body Monotonic is separate;
+
----------------------------------
-- ATCB allocation/deallocation --
----------------------------------
procedure Abort_Handler (signo : Signal);
- function Compute_Base_Monotonic_Clock return Duration;
- -- The monotonic clock epoch is set to some undetermined time in the past
- -- (typically system boot time). In order to use the monotonic clock for
- -- absolute time, the offset from a known epoch is needed.
-
function GNAT_pthread_condattr_setup
(attr : access pthread_condattr_t) return C.int;
pragma Import
end if;
end Abort_Handler;
- ----------------------------------
- -- Compute_Base_Monotonic_Clock --
- ----------------------------------
-
- function Compute_Base_Monotonic_Clock return Duration is
- Aft : Duration;
- Bef : Duration;
- Mon : Duration;
- Res_A : Interfaces.C.int;
- Res_B : Interfaces.C.int;
- Res_M : Interfaces.C.int;
- TS_Aft : aliased timespec;
- TS_Aft0 : aliased timespec;
- TS_Bef : aliased timespec;
- TS_Bef0 : aliased timespec;
- TS_Mon : aliased timespec;
- TS_Mon0 : aliased timespec;
-
- begin
- Res_B :=
- clock_gettime
- (clock_id => OSC.CLOCK_REALTIME,
- tp => TS_Bef0'Unchecked_Access);
- pragma Assert (Res_B = 0);
-
- Res_M :=
- clock_gettime
- (clock_id => OSC.CLOCK_RT_Ada,
- tp => TS_Mon0'Unchecked_Access);
- pragma Assert (Res_M = 0);
-
- Res_A :=
- clock_gettime
- (clock_id => OSC.CLOCK_REALTIME,
- tp => TS_Aft0'Unchecked_Access);
- pragma Assert (Res_A = 0);
-
- for I in 1 .. 10 loop
-
- -- Guard against a leap second that will cause CLOCK_REALTIME to jump
- -- backwards. In the extrenmely unlikely event we call clock_gettime
- -- before and after the jump the epoch, the result will be off
- -- slightly.
- -- Use only results where the tv_sec values match, for the sake of
- -- convenience.
- -- Also try to calculate the most accurate epoch by taking the
- -- minimum difference of 10 tries.
-
- Res_B :=
- clock_gettime
- (clock_id => OSC.CLOCK_REALTIME,
- tp => TS_Bef'Unchecked_Access);
- pragma Assert (Res_B = 0);
-
- Res_M :=
- clock_gettime
- (clock_id => OSC.CLOCK_RT_Ada,
- tp => TS_Mon'Unchecked_Access);
- pragma Assert (Res_M = 0);
-
- Res_A :=
- clock_gettime
- (clock_id => OSC.CLOCK_REALTIME,
- tp => TS_Aft'Unchecked_Access);
- pragma Assert (Res_A = 0);
-
- -- The calls to clock_gettime before the loop were no good
-
- if (TS_Bef0.tv_sec /= TS_Aft0.tv_sec
- and then TS_Bef.tv_sec = TS_Aft.tv_sec)
-
- -- The most recent calls to clock_gettime were better
-
- or else
- (TS_Bef0.tv_sec = TS_Aft0.tv_sec
- and then TS_Bef.tv_sec = TS_Aft.tv_sec
- and then (TS_Aft.tv_nsec - TS_Bef.tv_nsec
- < TS_Aft0.tv_nsec - TS_Bef0.tv_nsec))
- then
- TS_Bef0 := TS_Bef;
- TS_Aft0 := TS_Aft;
- TS_Mon0 := TS_Mon;
- end if;
- end loop;
-
- Bef := To_Duration (TS_Bef0);
- Mon := To_Duration (TS_Mon0);
- Aft := To_Duration (TS_Aft0);
-
- -- Distribute the division, to avoid potential type overflow someday
-
- return Bef / 2 + Aft / 2 - Mon;
- end Compute_Base_Monotonic_Clock;
-
--------------
-- Lock_RTS --
--------------
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time - Base_Monotonic_Clock;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- Abs_Time :=
- (if Mode = Relative
- then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay,
- Time - Base_Monotonic_Clock));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time + Base_Monotonic_Clock <= Check_Time
- or else Check_Time < Base_Time;
-
- if Result in 0 | EINTR then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- pragma Assert (Result = ETIMEDOUT);
- end loop;
- end if;
- end Timed_Sleep;
+ Yielded : out Boolean) renames Monotonic.Timed_Sleep;
-----------------
-- Timed_Delay --
procedure Timed_Delay
(Self_ID : Task_Id;
Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time - Base_Monotonic_Clock;
- Abs_Time : Duration;
- Request : aliased timespec;
-
- Result : C.int;
- pragma Warnings (Off, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- Abs_Time :=
- (if Mode = Relative
- then Time + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay,
- Time - Base_Monotonic_Clock));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time + Base_Monotonic_Clock <= Check_Time
- or else Check_Time < Base_Time;
-
- pragma Assert (Result in 0 | ETIMEDOUT | EINTR);
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- Result := sched_yield;
- end Timed_Delay;
+ Mode : ST.Delay_Modes) renames Monotonic.Timed_Delay;
---------------------
-- Monotonic_Clock --
---------------------
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := clock_gettime
- (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return Base_Monotonic_Clock + To_Duration (TS);
- end Monotonic_Clock;
+ function Monotonic_Clock return Duration renames Monotonic.Monotonic_Clock;
-------------------
-- RT_Resolution --
-------------------
- function RT_Resolution return Duration is
- TS : aliased timespec;
- Result : C.int;
-
- begin
- Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return To_Duration (TS);
- end RT_Resolution;
+ function RT_Resolution return Duration renames Monotonic.RT_Resolution;
------------
-- Wakeup --
Interrupt_Management.Initialize;
- Base_Monotonic_Clock := Compute_Base_Monotonic_Clock;
-
-- Prepare the set of signals that should be unblocked in all tasks
Result := sigemptyset (Unblocked_Signal_Mask'Access);
package body Specific is separate;
-- The body of this package is target specific
+ package Monotonic is
+
+ function Monotonic_Clock return Duration;
+ pragma Inline (Monotonic_Clock);
+ -- Returns "absolute" time, represented as an offset relative to "the
+ -- Epoch", which is Jan 1, 1970. This clock implementation is immune to
+ -- the system's clock changes.
+
+ function RT_Resolution return Duration;
+ pragma Inline (RT_Resolution);
+ -- Returns resolution of the underlying clock used to implement RT_Clock
+
+ procedure Timed_Sleep
+ (Self_ID : ST.Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean);
+ -- Combination of Sleep (above) and Timed_Delay
+
+ procedure Timed_Delay
+ (Self_ID : ST.Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes);
+ -- Implement the semantics of the delay statement.
+ -- The caller should be abort-deferred and should not hold any locks.
+
+ end Monotonic;
+
+ package body Monotonic is separate;
+
----------------------------------
-- ATCB allocation/deallocation --
----------------------------------
pragma Import (C,
GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
- procedure Compute_Deadline
- (Time : Duration;
- Mode : ST.Delay_Modes;
- Check_Time : out Duration;
- Abs_Time : out Duration;
- Rel_Time : out Duration);
- -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by
- -- Time and Mode, compute the current clock reading (Check_Time), and the
- -- target absolute and relative clock readings (Abs_Time, Rel_Time). The
- -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time
- -- is always that of CLOCK_RT_Ada.
-
-------------------
-- Abort_Handler --
-------------------
end if;
end Abort_Handler;
- ----------------------
- -- Compute_Deadline --
- ----------------------
-
- procedure Compute_Deadline
- (Time : Duration;
- Mode : ST.Delay_Modes;
- Check_Time : out Duration;
- Abs_Time : out Duration;
- Rel_Time : out Duration)
- is
- begin
- Check_Time := Monotonic_Clock;
-
- -- Relative deadline
-
- if Mode = Relative then
- Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
-
- if Relative_Timed_Wait then
- Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
- end if;
-
- pragma Warnings (Off);
- -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile
- -- time known.
-
- -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada)
-
- elsif Mode = Absolute_RT
- or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME
- then
- pragma Warnings (On);
- Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
-
- if Relative_Timed_Wait then
- Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
- end if;
-
- -- Absolute deadline specified using the calendar clock, in the
- -- case where it is not the same as the tasking clock: compensate for
- -- difference between clock epochs (Base_Time - Base_Cal_Time).
-
- else
- declare
- Cal_Check_Time : constant Duration := OS_Primitives.Clock;
- RT_Time : constant Duration :=
- Time + Check_Time - Cal_Check_Time;
-
- begin
- Abs_Time :=
- Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time);
-
- if Relative_Timed_Wait then
- Rel_Time :=
- Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time);
- end if;
- end;
- end if;
- end Compute_Deadline;
-
-----------------
-- Stack_Guard --
-----------------
Mode : ST.Delay_Modes;
Reason : Task_States;
Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Base_Time : Duration;
- Check_Time : Duration;
- Abs_Time : Duration;
- Rel_Time : Duration;
-
- Request : aliased timespec;
- Result : Interfaces.C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- Compute_Deadline
- (Time => Time,
- Mode => Mode,
- Check_Time => Check_Time,
- Abs_Time => Abs_Time,
- Rel_Time => Rel_Time);
- Base_Time := Check_Time;
-
- if Abs_Time > Check_Time then
- Request :=
- To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- if Result = 0 or Result = EINTR then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- pragma Assert (Result = ETIMEDOUT);
- end loop;
- end if;
- end Timed_Sleep;
+ Yielded : out Boolean) renames Monotonic.Timed_Sleep;
-----------------
-- Timed_Delay --
procedure Timed_Delay
(Self_ID : Task_Id;
Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Base_Time : Duration;
- Check_Time : Duration;
- Abs_Time : Duration;
- Rel_Time : Duration;
- Request : aliased timespec;
-
- Result : Interfaces.C.int;
- pragma Warnings (Off, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- Compute_Deadline
- (Time => Time,
- Mode => Mode,
- Check_Time => Check_Time,
- Abs_Time => Abs_Time,
- Rel_Time => Rel_Time);
- Base_Time := Check_Time;
-
- if Abs_Time > Check_Time then
- Request :=
- To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- pragma Assert (Result = 0
- or else Result = ETIMEDOUT
- or else Result = EINTR);
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- Result := sched_yield;
- end Timed_Delay;
+ Mode : ST.Delay_Modes) renames Monotonic.Timed_Delay;
---------------------
-- Monotonic_Clock --
---------------------
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := clock_gettime
- (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
+ function Monotonic_Clock return Duration renames Monotonic.Monotonic_Clock;
-------------------
-- RT_Resolution --
-------------------
- function RT_Resolution return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return To_Duration (TS);
- end RT_Resolution;
+ function RT_Resolution return Duration renames Monotonic.RT_Resolution;
------------
-- Wakeup --
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.MONOTONIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Monotonic version of this package for Posix and Linux targets.
+
+separate (System.Task_Primitives.Operations)
+package body Monotonic is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Compute_Deadline
+ (Time : Duration;
+ Mode : ST.Delay_Modes;
+ Check_Time : out Duration;
+ Abs_Time : out Duration;
+ Rel_Time : out Duration);
+ -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by
+ -- Time and Mode, compute the current clock reading (Check_Time), and the
+ -- target absolute and relative clock readings (Abs_Time, Rel_Time). The
+ -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time
+ -- is always that of CLOCK_RT_Ada.
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+ Result := clock_gettime
+ (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return To_Duration (TS);
+ end RT_Resolution;
+
+ ----------------------
+ -- Compute_Deadline --
+ ----------------------
+
+ procedure Compute_Deadline
+ (Time : Duration;
+ Mode : ST.Delay_Modes;
+ Check_Time : out Duration;
+ Abs_Time : out Duration;
+ Rel_Time : out Duration)
+ is
+ begin
+ Check_Time := Monotonic_Clock;
+
+ -- Relative deadline
+
+ if Mode = Relative then
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+
+ if Relative_Timed_Wait then
+ Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
+ end if;
+
+ pragma Warnings (Off);
+ -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile
+ -- time known.
+
+ -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada)
+
+ elsif Mode = Absolute_RT
+ or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME
+ then
+ pragma Warnings (On);
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+
+ if Relative_Timed_Wait then
+ Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
+ end if;
+
+ -- Absolute deadline specified using the calendar clock, in the
+ -- case where it is not the same as the tasking clock: compensate for
+ -- difference between clock epochs (Base_Time - Base_Cal_Time).
+
+ else
+ declare
+ Cal_Check_Time : constant Duration := OS_Primitives.Clock;
+ RT_Time : constant Duration :=
+ Time + Check_Time - Cal_Check_Time;
+
+ begin
+ Abs_Time :=
+ Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time);
+
+ if Relative_Timed_Wait then
+ Rel_Time :=
+ Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time);
+ end if;
+ end;
+ end if;
+ end Compute_Deadline;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ -- This is for use within the run-time system, so abort is
+ -- assumed to be already deferred, and the caller should be
+ -- holding its own ATCB lock.
+
+ procedure Timed_Sleep
+ (Self_ID : ST.Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Base_Time : Duration;
+ Check_Time : Duration;
+ Abs_Time : Duration;
+ Rel_Time : Duration;
+
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ Compute_Deadline
+ (Time => Time,
+ Mode => Mode,
+ Check_Time => Check_Time,
+ Abs_Time => Abs_Time,
+ Rel_Time => Rel_Time);
+ Base_Time := Check_Time;
+
+ if Abs_Time > Check_Time then
+ Request :=
+ To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ if Result in 0 | EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is abort-deferred but is holding no locks.
+
+ procedure Timed_Delay
+ (Self_ID : ST.Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Base_Time : Duration;
+ Check_Time : Duration;
+ Abs_Time : Duration;
+ Rel_Time : Duration;
+ Request : aliased timespec;
+
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ Compute_Deadline
+ (Time => Time,
+ Mode => Mode,
+ Check_Time => Check_Time,
+ Abs_Time => Abs_Time,
+ Rel_Time => Rel_Time);
+ Base_Time := Check_Time;
+
+ if Abs_Time > Check_Time then
+ Request :=
+ To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ pragma Assert (Result in 0 | ETIMEDOUT | EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Result := sched_yield;
+ end Timed_Delay;
+
+end Monotonic;
-- Deal with use clauses within the context area if the current
-- scope is a compilation unit.
- if Is_Compilation_Unit (Current_Scope) then
-
- pragma Assert (Scope_Stack.Last /= Scope_Stack.First);
-
+ if Is_Compilation_Unit (Current_Scope)
+ and then Sloc (Scope_Stack.Table
+ (Scope_Stack.Last - 1).Entity) = Standard_Location
+ then
Update_Chain_In_Scope (Scope_Stack.Last - 1);
end if;
end Update_Use_Clause_Chain;
function Is_Controlling_Limited_Procedure
(Proc_Nam : Entity_Id) return Boolean
is
+ Param : Node_Id;
Param_Typ : Entity_Id := Empty;
begin
if Ekind (Proc_Nam) = E_Procedure
and then Present (Parameter_Specifications (Parent (Proc_Nam)))
then
- Param_Typ := Etype (Parameter_Type (First (
- Parameter_Specifications (Parent (Proc_Nam)))));
+ Param := Parameter_Type (First (
+ Parameter_Specifications (Parent (Proc_Nam))));
- -- In this case where an Itype was created, the procedure call has been
- -- rewritten.
+ -- The formal may be an anonymous access type.
+
+ if Nkind (Param) = N_Access_Definition then
+ Param_Typ := Entity (Subtype_Mark (Param));
+
+ else
+ Param_Typ := Etype (Param);
+ end if;
+
+ -- In the case where an Itype was created for a dispatchin call, the
+ -- procedure call has been rewritten. The actual may be an access to
+ -- interface type in which case it is the designated type that is the
+ -- controlling type.
elsif Present (Associated_Node_For_Itype (Proc_Nam))
and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
Param_Typ :=
Etype (First (Parameter_Associations
(Associated_Node_For_Itype (Proc_Nam))));
+
+ if Ekind (Param_Typ) = E_Anonymous_Access_Type then
+ Param_Typ := Directly_Designated_Type (Param_Typ);
+ end if;
end if;
if Present (Param_Typ) then
+2017-10-20 Ed Schonberg <schonberg@adacore.com>
+
+ * gnat.dg/sync_iface_call.adb, gnat.dg/sync_iface_call_pkg.ads,
+ gnat.dg/sync_iface_call_pkg2.adb, gnat.dg/sync_iface_call_pkg2.ads:
+ New testcase.
+
2017-10-20 Justin Squirek <squirek@adacore.com>
* gnat.dg/default_pkg_actual.adb, gnat.dg/default_pkg_actual2.adb: New
--- /dev/null
+-- { dg-do compile }
+
+with Sync_Iface_Call_Pkg;
+with Sync_Iface_Call_Pkg2;
+
+procedure Sync_Iface_Call is
+
+ Impl : access Sync_Iface_Call_Pkg.IFace'Class :=
+ new Sync_Iface_Call_Pkg2.Impl;
+ Val : aliased Integer := 10;
+begin
+ select
+ Impl.Do_Stuff (Val);
+ or
+ delay 10.0;
+ end select;
+ select
+ Impl.Do_Stuff_Access (Val'Access);
+ or
+ delay 10.0;
+ end select;
+
+ select
+ Impl.Do_Stuff_2 (Val);
+ or
+ delay 10.0;
+ end select;
+
+ select
+ Impl.Do_Stuff_2_Access (Val'Access);
+ or
+ delay 10.0;
+ end select;
+end Sync_Iface_Call;
--- /dev/null
+package Sync_Iface_Call_Pkg is
+
+ type IFace is synchronized interface;
+
+ procedure Do_Stuff
+ (This : in out IFace;
+ Value : in Integer) is null;
+
+ procedure Do_Stuff_Access
+ (This : in out IFace;
+ Value : not null access Integer) is null;
+
+ procedure Do_Stuff_2
+ (This : not null access IFace;
+ Value : in Integer) is null;
+
+ procedure Do_Stuff_2_Access
+ (This : not null access IFace;
+ Value : not null access Integer) is null;
+
+end Sync_Iface_Call_Pkg;
--- /dev/null
+package body Sync_Iface_Call_Pkg2 is
+
+ task body Impl is
+ begin
+ null;
+ end Impl;
+
+end Sync_Iface_Call_Pkg2;
--- /dev/null
+with Sync_Iface_Call_Pkg;
+
+package Sync_Iface_Call_Pkg2 is
+
+ task type Impl is new Sync_Iface_Call_Pkg.IFace with end;
+
+end Sync_Iface_Call_Pkg2;
projects / gcc.git / commitdiff