blob: fddc16b32103ea0691ebd88b30c5b754af48c671 [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) 2012-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/>. --
------------------------------------------------------------------------------
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);
---------
-- "=" --
---------
function "=" (Left, Right : Holder) return Boolean is
begin
if Left.Element = null and Right.Element = null then
return True;
elsif Left.Element /= null and Right.Element /= null then
return Left.Element.all = Right.Element.all;
else
return False;
end if;
end "=";
------------
-- Adjust --
------------
overriding procedure Adjust (Container : in out Holder) is
begin
if Container.Element /= null then
Container.Element := new Element_Type'(Container.Element.all);
end if;
Container.Busy := 0;
end Adjust;
overriding procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
B : Natural renames Control.Container.Busy;
begin
B := B + 1;
end;
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.Element /= Source.Element then
Free (Target.Element);
if Source.Element /= null then
Target.Element := new Element_Type'(Source.Element.all);
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;
Free (Container.Element);
end Clear;
------------------------
-- Constant_Reference --
------------------------
function Constant_Reference
(Container : aliased Holder) return Constant_Reference_Type
is
Ref : constant Constant_Reference_Type :=
(Element => Container.Element.all'Access,
Control => (Controlled with Container'Unrestricted_Access));
B : Natural renames Ref.Control.Container.Busy;
begin
B := B + 1;
return Ref;
end Constant_Reference;
----------
-- Copy --
----------
function Copy (Source : Holder) return Holder is
begin
if Source.Element = null then
return (Controlled with null, 0);
else
return (Controlled with new Element_Type'(Source.Element.all), 0);
end if;
end Copy;
-------------
-- Element --
-------------
function Element (Container : Holder) return Element_Type is
begin
if Container.Element = null then
raise Constraint_Error with "container is empty";
else
return Container.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;
Free (Container.Element);
end Finalize;
overriding procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
B : Natural renames Control.Container.Busy;
begin
B := B - 1;
end;
end if;
Control.Container := null;
end Finalize;
--------------
-- Is_Empty --
--------------
function Is_Empty (Container : Holder) return Boolean is
begin
return Container.Element = 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.Element /= Source.Element then
Free (Target.Element);
Target.Element := Source.Element;
Source.Element := 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.Element = null then
raise Constraint_Error with "container is empty";
end if;
B := B + 1;
begin
Process (Container.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.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 --
---------------
function Reference
(Container : aliased in out Holder) return Reference_Type
is
Ref : constant Reference_Type :=
(Element => Container.Element.all'Access,
Control => (Controlled with Container'Unrestricted_Access));
begin
Container.Busy := Container.Busy + 1;
return Ref;
end Reference;
---------------------
-- Replace_Element --
---------------------
procedure Replace_Element
(Container : in out Holder;
New_Item : Element_Type)
is
begin
if Container.Busy /= 0 then
raise Program_Error with "attempt to tamper with elements";
end if;
declare
X : Element_Access := Container.Element;
-- 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
Container.Element := new Element_Type'(New_Item);
Free (X);
end;
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.Element /= Right.Element then
declare
Tmp : constant Element_Access := Left.Element;
begin
Left.Element := Right.Element;
Right.Element := 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 Element_Type'(New_Item), 0);
end To_Holder;
--------------------
-- 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.Element = null then
raise Constraint_Error with "container is empty";
end if;
B := B + 1;
begin
Process (Container.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.Element = null);
if Container.Element /= null then
Element_Type'Output (Stream, Container.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;