------------------------------------------------------------------------------ -- -- -- GLADE TOOLS -- -- -- -- G L A D E . U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1996-2020 Free Software Foundation, Inc. -- -- -- -- GLADE 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 2, or (at your option) any later ver- -- -- sion. GLADE is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- -- -- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with GLADE; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Unchecked_Deallocation; with System.Tasking_Soft_Links; use System.Tasking_Soft_Links; package body GLADE.Utils is use Ada.Task_Identification; protected type Barrier_PO is entry Wait; procedure Signal (How_Many : Positive := 1); procedure Signal_All (Permanent : Boolean); private Free : Natural := 0; Perm : Boolean := False; end Barrier_PO; -- Any number of task may be waiting on Wait. Signal unblocks How_Many -- tasks (the order depends on the queuing policy) and Signal_All -- unblocks all the tasks and Wait will no longer be blocking. If -- How_Many is more than the number of tasks waiting, new tasks will be -- awakened as well. protected type Mutex_PO is entry Enter; procedure Leave; private Locked : Boolean := False; end Mutex_PO; protected type Watcher_PO is function Lookup return Version_Id; procedure Update; entry Differ (V : in Version_Id); private entry Await (V : in Version_Id); Current : Version_Id := Version_Id'First; Passing : Boolean := True; end Watcher_PO; type Adv_Mutex_PO is limited record Mutex : Mutex_Type; Current : Ada.Task_Identification.Task_Id; pragma Atomic (Current); Level : Natural; pragma Atomic (Level); end record; -- This is a classical critical section except that when a task try to -- Enter a critical section several times without leaving it first it -- is not blocked and can continue. Leave keeps track of the number of -- times Enter has been successful. procedure Free is new Ada.Unchecked_Deallocation (Mutex_PO, Mutex_Type); procedure Free is new Ada.Unchecked_Deallocation (Adv_Mutex_PO, Adv_Mutex_Type); procedure Free is new Ada.Unchecked_Deallocation (Watcher_PO, Watcher_Type); procedure Free is new Ada.Unchecked_Deallocation (Barrier_PO, Barrier_Type); ---------------------- -- Access_To_String -- ---------------------- function Access_To_String (S : String_Access) return String is begin return S.all; end Access_To_String; ------------------ -- Barrier_PO -- ------------------ protected body Barrier_PO is ------------ -- Signal -- ------------ procedure Signal (How_Many : Positive := 1) is begin if not Perm then Free := Free + How_Many; end if; end Signal; ---------------- -- Signal_All -- ---------------- procedure Signal_All (Permanent : Boolean) is begin if not Perm then if Permanent then Perm := True; else Free := Free + Wait'Count; end if; end if; end Signal_All; ---------- -- Wait -- ---------- entry Wait when Perm or else Free > 0 is begin if not Perm then Free := Free - 1; end if; end Wait; end Barrier_PO; ------------ -- Lookup -- ------------ procedure Lookup (W : in Watcher_Type; V : out Version_Id) is begin pragma Assert (W /= null); V := W.Lookup; end Lookup; ------------ -- Create -- ------------ procedure Create (B : out Barrier_Type) is begin B := new Barrier_PO; end Create; ------------ -- Create -- ------------ procedure Create (W : out Watcher_Type) is begin W := new Watcher_PO; end Create; ------------ -- Create -- ------------ procedure Create (M : out Adv_Mutex_Type) is begin M := new Adv_Mutex_PO; Create (M.Mutex); M.Current := Null_Task_Id; M.Level := 0; end Create; ------------ -- Create -- ------------ procedure Create (M : out Mutex_Type) is begin M := new Mutex_PO; end Create; ------------- -- Destroy -- ------------- procedure Destroy (B : in out Barrier_Type) is begin Free (B); end Destroy; ------------- -- Destroy -- ------------- procedure Destroy (W : in out Watcher_Type) is begin Free (W); end Destroy; ------------- -- Destroy -- ------------- procedure Destroy (M : in out Adv_Mutex_Type) is begin pragma Assert (M /= null); Destroy (M.Mutex); Free (M); end Destroy; ------------- -- Destroy -- ------------- procedure Destroy (M : in out Mutex_Type) is begin Free (M); end Destroy; ------------ -- Differ -- ------------ procedure Differ (W : in Watcher_Type; V : in Version_Id) is begin pragma Assert (W /= null); W.Differ (V); end Differ; ----------- -- Enter -- ----------- procedure Enter (M : Mutex_Type) is begin pragma Assert (M /= null); Abort_Defer.all; M.Enter; end Enter; ----------- -- Enter -- ----------- procedure Enter (M : Adv_Mutex_Type) is Self : constant Task_Id := Current_Task; begin pragma Assert (M /= null); if M.Current /= Self then Enter (M.Mutex); pragma Assert (M.Current = Null_Task_Id); pragma Assert (M.Level = 0); M.Current := Self; end if; M.Level := M.Level + 1; end Enter; ----------- -- Leave -- ----------- procedure Leave (M : in Adv_Mutex_Type) is begin pragma Assert (M /= null and then M.Current = Current_Task and then M.Level > 0); M.Level := M.Level - 1; if M.Level = 0 then M.Current := Null_Task_Id; Leave (M.Mutex); end if; end Leave; ----------- -- Leave -- ----------- procedure Leave (M : in Mutex_Type) is begin pragma Assert (M /= null); Abort_Undefer.all; M.Leave; end Leave; -------------- -- Mutex_PO -- -------------- protected body Mutex_PO is ----------- -- Enter -- ----------- entry Enter when not Locked is begin Locked := True; end Enter; ------------ -- Leave -- ------------ procedure Leave is begin Locked := False; end Leave; end Mutex_PO; ---------------------- -- String_To_Access -- ---------------------- function String_To_Access (S : String) return String_Access is begin return new String'(S); end String_To_Access; ------------ -- Signal -- ------------ procedure Signal (B : in Barrier_Type; N : in Positive := 1) is begin pragma Assert (B /= null); B.Signal (N); end Signal; ---------------- -- Signal_All -- ---------------- procedure Signal_All (B : in Barrier_Type; P : in Boolean := True) is begin pragma Assert (B /= null); B.Signal_All (P); end Signal_All; -------------- -- To_Lower -- -------------- procedure To_Lower (Item : in out String) is begin for I in Item'Range loop if Item (I) in 'A' .. 'Z' then Item (I) := Character'Val (Character'Pos (Item (I)) - Character'Pos ('A') + Character'Pos ('a')); end if; end loop; end To_Lower; ------------ -- Update -- ------------ procedure Update (W : in Watcher_Type) is begin pragma Assert (W /= null); W.Update; end Update; ---------- -- Wait -- ---------- procedure Wait (B : in Barrier_Type) is begin pragma Assert (B /= null); B.Wait; end Wait; ---------------- -- Watcher_PO -- ---------------- protected body Watcher_PO is ----------- -- Await -- ----------- entry Await (V : in Version_Id) when not Passing is begin if Await'Count = 0 then Passing := True; end if; requeue Differ with abort; end Await; ------------ -- Lookup -- ------------ function Lookup return Version_Id is begin return Current; end Lookup; ------------ -- Differ -- ------------ entry Differ (V : in Version_Id) when Passing is begin if Current = V then requeue Await with abort; end if; end Differ; ------------ -- Update -- ------------ procedure Update is begin Current := Current + 1; if Current = No_Version then Current := Current + 1; end if; if Await'Count /= 0 then Passing := False; end if; end Update; end Watcher_PO; end GLADE.Utils;