+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Cond_Attr : aliased pthread_condattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Initialize internal state (always to False (RM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ -- Initialize internal condition variable
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := pthread_cond_destroy (S.CV'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ S.State := False;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- If there is already a task waiting on this suspension object then we
+ -- resume it, leaving the state of the suspension object to False, as
+ -- specified in (RM D.10(9)). Otherwise, leave the state set to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := pthread_cond_signal (S.CV'Access);
+ pragma Assert (Result = 0);
+
+ else
+ S.State := True;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if S.Waiting then
+
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (AM D.10(10)).
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+
+ raise Program_Error;
+
+ else
+ -- Suspend the task if the state is False. Otherwise, the task
+ -- continues its execution, and the state of the suspension object
+ -- is set to False (RM D.10(9)).
+
+ if S.State then
+ S.State := False;
+ else
+ S.Waiting := True;
+
+ loop
+ -- Loop in case pthread_cond_wait returns earlier than expected
+ -- (e.g. in case of EINTR caused by a signal).
+
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ pragma Assert (Result = 0 or else Result = EINTR);
+
+ exit when not S.Waiting;
+ end loop;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------