diff mbox

[Ada] AI05-0069 : Holder container

Message ID 20110804152816.GA4259@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Aug. 4, 2011, 3:28 p.m. UTC
This AI defines a package Ada.Containers.Indefinite_Holders in order
to create the ability to hold a single object of an indefinite type. 

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-04  Vadim Godunko  <godunko@adacore.com>

	* impunit.adb (Non_Imp_File_Names_12): Add "a-coinho".
	* a-coinho.ads, a-coinho.adb: New file.
	* Makefile.rtl: Add Ada.Containers.Indefinite_Holders.
diff mbox

Patch

Index: a-coinho.adb
===================================================================
--- a-coinho.adb	(revision 0)
+++ a-coinho.adb	(revision 0)
@@ -0,0 +1,282 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT LIBRARY COMPONENTS                          --
+--                                                                          --
+--       A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S        --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--             Copyright (C) 2011, 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;
+
+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;
+
+   ------------
+   -- 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;
+
+   ----------
+   -- Copy --
+   ----------
+
+   function Copy (Source : Holder) return Holder is
+   begin
+      if Source.Element = null then
+         return (AF.Controlled with null, 0);
+
+      else
+         return (AF.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;
+
+   --------------
+   -- 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;
+
+   ----------
+   -- 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;
+
+   ---------------------
+   -- 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;
+
+      Free (Container.Element);
+      Container.Element := new Element_Type'(New_Item);
+   end Replace_Element;
+
+   ---------------
+   -- To_Holder --
+   ---------------
+
+   function To_Holder (New_Item : Element_Type) return Holder is
+   begin
+      return (AF.Controlled with new Element_Type'(New_Item), 0);
+   end To_Holder;
+
+   --------------------
+   -- Update_Element --
+   --------------------
+
+   procedure Update_Element
+     (Container : Holder;
+      Process   : not null access procedure (Element : in out 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 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;
+
+end Ada.Containers.Indefinite_Holders;
Index: a-coinho.ads
===================================================================
--- a-coinho.ads	(revision 0)
+++ a-coinho.ads	(revision 0)
@@ -0,0 +1,100 @@ 
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT LIBRARY COMPONENTS                          --
+--                                                                          --
+--       A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S        --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--             Copyright (C) 2011, Free Software Foundation, Inc.           --
+--                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
+-- 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/>.                                          --
+------------------------------------------------------------------------------
+
+private with Ada.Finalization;
+private with Ada.Streams;
+
+generic
+   type Element_Type (<>) is private;
+   with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Holders is
+   pragma Preelaborate (Indefinite_Holders);
+   pragma Remote_Types (Indefinite_Holders);
+
+   type Holder is tagged private;
+   pragma Preelaborable_Initialization (Holder);
+
+   Empty_Holder : constant Holder;
+
+   function "=" (Left, Right : Holder) return Boolean;
+
+   function To_Holder (New_Item : Element_Type) return Holder;
+
+   function Is_Empty (Container : Holder) return Boolean;
+
+   procedure Clear (Container : in out Holder);
+
+   function Element (Container : Holder) return Element_Type;
+
+   procedure Replace_Element
+     (Container : in out Holder; New_Item : Element_Type);
+
+   procedure Query_Element
+     (Container : Holder;
+      Process   : not null access procedure (Element : Element_Type));
+   procedure Update_Element
+     (Container : Holder;
+      Process   : not null access procedure (Element : in out Element_Type));
+
+   procedure Assign (Target : in out Holder; Source : Holder);
+
+   function Copy (Source : Holder) return Holder;
+
+   procedure Move (Target : in out Holder; Source : in out Holder);
+
+private
+
+   package AF renames Ada.Finalization;
+
+   type Element_Access is access all Element_Type;
+
+   procedure Read
+     (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
+      Container : out Holder);
+
+   procedure Write
+     (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
+      Container : Holder);
+
+   type Holder is new Ada.Finalization.Controlled with record
+      Element : Element_Access;
+      Busy    : Natural := 0;
+   end record;
+   for Holder'Read use Read;
+   for Holder'Write use Write;
+
+   overriding procedure Adjust (Container : in out Holder);
+   overriding procedure Finalize (Container : in out Holder);
+
+   Empty_Holder : constant Holder := (AF.Controlled with null, 0);
+
+end Ada.Containers.Indefinite_Holders;
Index: impunit.adb
===================================================================
--- impunit.adb	(revision 177389)
+++ impunit.adb	(working copy)
@@ -514,6 +514,7 @@ 
      "a-cborma",    -- Ada.Containers.Bounded_Ordered_Maps
      "a-cbhase",    -- Ada.Containers.Bounded_Hashed_Sets
      "a-cbhama",    -- Ada.Containers.Bounded_Hashed_Maps
+     "a-coinho",    -- Ada.Containers.Indefinite_Holders
      "a-extiin",    -- Ada.Execution_Time.Interrupts
 
    -----------------------------------------
Index: Makefile.rtl
===================================================================
--- Makefile.rtl	(revision 177336)
+++ Makefile.rtl	(working copy)
@@ -121,6 +121,7 @@ 
   a-cohama$(objext) \
   a-cohase$(objext) \
   a-cohata$(objext) \
+  a-coinho$(objext) \
   a-coinve$(objext) \
   a-colien$(objext) \
   a-colire$(objext) \