blob: d540612a3cb2e964dfa4711f1bd2c5abf9a56379 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2013-2022, Free Software Foundation, Inc. --
-- --
-- GNAT 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/>. --
------------------------------------------------------------------------------
-- Note: special attention must be paid to the case of simultaneous access
-- to internal shared objects and elements by different tasks. The Reference
-- counter of internal shared object is the only component protected using
-- atomic operations; other components and elements can be modified only when
-- reference counter is equal to one (so there are no other references to this
-- internal shared object and element).
with Ada.Unchecked_Deallocation;
with System.Put_Images;
package body Ada.Containers.Indefinite_Holders is
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
procedure Detach (Container : Holder);
-- Detach data from shared copy if necessary. This is necessary to prepare
-- container to be modified.
---------
-- "=" --
---------
function "=" (Left, Right : Holder) return Boolean is
begin
if Left.Reference = Right.Reference then
-- Covers both null and not null but the same shared object cases
return True;
elsif Left.Reference /= null and Right.Reference /= null then
return Left.Reference.Element.all = Right.Reference.Element.all;
else
return False;
end if;
end "=";
------------
-- Adjust --
------------
overriding procedure Adjust (Container : in out Holder) is
begin
if Container.Reference /= null then
if Container.Busy = 0 then
-- Container is not locked, reuse existing internal shared object
Reference (Container.Reference);
else
-- Otherwise, create copy of both internal shared object and
-- element.
Container.Reference :=
new Shared_Holder'
(Counter => <>,
Element =>
new Element_Type'(Container.Reference.Element.all));
end if;
end if;
Container.Busy := 0;
end Adjust;
overriding procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
Reference (Control.Container.Reference);
Control.Container.Busy := Control.Container.Busy + 1;
end if;
end Adjust;
------------
-- Assign --
------------
procedure Assign (Target : in out Holder; Source : Holder) is
begin
if Target.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
if Target.Reference /= Source.Reference then
if Target.Reference /= null then
Unreference (Target.Reference);
end if;
Target.Reference := Source.Reference;
if Source.Reference /= null then
Reference (Target.Reference);
end if;
end if;
end Assign;
-----------
-- Clear --
-----------
procedure Clear (Container : in out Holder) is
begin
if Container.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
if Container.Reference /= null then
Unreference (Container.Reference);
Container.Reference := null;
end if;
end Clear;
------------------------
-- Constant_Reference --
------------------------
function Constant_Reference
(Container : aliased Holder) return Constant_Reference_Type is
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
end if;
Detach (Container);
declare
Ref : constant Constant_Reference_Type :=
(Element => Container.Reference.Element.all'Access,
Control => (Controlled with Container'Unrestricted_Access));
begin
Reference (Ref.Control.Container.Reference);
Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1;
return Ref;
end;
end Constant_Reference;
----------
-- Copy --
----------
function Copy (Source : Holder) return Holder is
begin
if Source.Reference = null then
return (Controlled with null, 0);
elsif Source.Busy = 0 then
-- Container is not locked, reuse internal shared object
Reference (Source.Reference);
return (Controlled with Source.Reference, 0);
else
-- Otherwise, create copy of both internal shared object and element
return
(Controlled with
new Shared_Holder'
(Counter => <>,
Element => new Element_Type'(Source.Reference.Element.all)),
0);
end if;
end Copy;
------------
-- Detach --
------------
procedure Detach (Container : Holder) is
begin
if Container.Busy = 0
and then not System.Atomic_Counters.Is_One
(Container.Reference.Counter)
then
-- Container is not locked and internal shared object is used by
-- other container, create copy of both internal shared object and
-- element.
declare
Old : constant Shared_Holder_Access := Container.Reference;
begin
Container'Unrestricted_Access.Reference :=
new Shared_Holder'
(Counter => <>,
Element =>
new Element_Type'(Container.Reference.Element.all));
Unreference (Old);
end;
end if;
end Detach;
-------------
-- Element --
-------------
function Element (Container : Holder) return Element_Type is
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
else
return Container.Reference.Element.all;
end if;
end Element;
--------------
-- Finalize --
--------------
overriding procedure Finalize (Container : in out Holder) is
begin
if Container.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
if Container.Reference /= null then
Unreference (Container.Reference);
Container.Reference := null;
end if;
end Finalize;
overriding procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
Unreference (Control.Container.Reference);
Control.Container.Busy := Control.Container.Busy - 1;
Control.Container := null;
end if;
end Finalize;
--------------
-- Is_Empty --
--------------
function Is_Empty (Container : Holder) return Boolean is
begin
return Container.Reference = null;
end Is_Empty;
----------
-- Move --
----------
procedure Move (Target : in out Holder; Source : in out Holder) is
begin
if Target.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
if Source.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
if Target.Reference /= Source.Reference then
if Target.Reference /= null then
Unreference (Target.Reference);
end if;
Target.Reference := Source.Reference;
Source.Reference := null;
end if;
end Move;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Container : Holder;
Process : not null access procedure (Element : Element_Type))
is
B : Natural renames Container'Unrestricted_Access.Busy;
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
end if;
Detach (Container);
B := B + 1;
begin
Process (Container.Reference.Element.all);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Query_Element;
---------------
-- Put_Image --
---------------
procedure Put_Image
(S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : Holder)
is
use System.Put_Images;
begin
Array_Before (S);
if not Is_Empty (V) then
Element_Type'Put_Image (S, Element (V));
end if;
Array_After (S);
end Put_Image;
----------
-- Read --
----------
procedure Read
(Stream : not null access Ada.Streams.Root_Stream_Type'Class;
Container : out Holder)
is
begin
Clear (Container);
if not Boolean'Input (Stream) then
Container.Reference :=
new Shared_Holder'
(Counter => <>,
Element => new Element_Type'(Element_Type'Input (Stream)));
end if;
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Constant_Reference_Type)
is
begin
raise Program_Error with "attempt to stream reference";
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Reference_Type)
is
begin
raise Program_Error with "attempt to stream reference";
end Read;
---------------
-- Reference --
---------------
procedure Reference (Item : not null Shared_Holder_Access) is
begin
System.Atomic_Counters.Increment (Item.Counter);
end Reference;
function Reference
(Container : aliased in out Holder) return Reference_Type
is
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
end if;
Detach (Container);
declare
Ref : constant Reference_Type :=
(Element => Container.Reference.Element.all'Access,
Control => (Controlled with Container'Unrestricted_Access));
begin
Reference (Ref.Control.Container.Reference);
Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1;
return Ref;
end;
end Reference;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element
(Container : in out Holder;
New_Item : Element_Type)
is
-- Element allocator may need an accessibility check in case actual type
-- is class-wide or has access discriminants (RM 4.8(10.1) and
-- AI12-0035).
pragma Unsuppress (Accessibility_Check);
begin
if Container.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
if Container.Reference = null then
-- Holder is empty, allocate new Shared_Holder.
Container.Reference :=
new Shared_Holder'
(Counter => <>,
Element => new Element_Type'(New_Item));
elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then
-- Shared_Holder can be reused.
Free (Container.Reference.Element);
Container.Reference.Element := new Element_Type'(New_Item);
else
Unreference (Container.Reference);
Container.Reference :=
new Shared_Holder'
(Counter => <>,
Element => new Element_Type'(New_Item));
end if;
end Replace_Element;
----------
-- Swap --
----------
procedure Swap (Left, Right : in out Holder) is
begin
if Left.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
if Right.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
if Left.Reference /= Right.Reference then
declare
Tmp : constant Shared_Holder_Access := Left.Reference;
begin
Left.Reference := Right.Reference;
Right.Reference := Tmp;
end;
end if;
end Swap;
---------------
-- To_Holder --
---------------
function To_Holder (New_Item : Element_Type) return Holder is
-- The element allocator may need an accessibility check in the case the
-- actual type is class-wide or has access discriminants (RM 4.8(10.1)
-- and AI12-0035).
pragma Unsuppress (Accessibility_Check);
begin
return
(Controlled with
new Shared_Holder'
(Counter => <>,
Element => new Element_Type'(New_Item)), 0);
end To_Holder;
-----------------
-- Unreference --
-----------------
procedure Unreference (Item : not null Shared_Holder_Access) is
procedure Free is
new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access);
Aux : Shared_Holder_Access := Item;
begin
if System.Atomic_Counters.Decrement (Aux.Counter) then
Free (Aux.Element);
Free (Aux);
end if;
end Unreference;
--------------------
-- Update_Element --
--------------------
procedure Update_Element
(Container : in out Holder;
Process : not null access procedure (Element : in out Element_Type))
is
B : Natural renames Container.Busy;
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
end if;
Detach (Container);
B := B + 1;
begin
Process (Container.Reference.Element.all);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Update_Element;
-----------
-- Write --
-----------
procedure Write
(Stream : not null access Ada.Streams.Root_Stream_Type'Class;
Container : Holder)
is
begin
Boolean'Output (Stream, Container.Reference = null);
if Container.Reference /= null then
Element_Type'Output (Stream, Container.Reference.Element.all);
end if;
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Reference_Type)
is
begin
raise Program_Error with "attempt to stream reference";
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Constant_Reference_Type)
is
begin
raise Program_Error with "attempt to stream reference";
end Write;
end Ada.Containers.Indefinite_Holders;