Re: Newbie question -- dereferencing access

[Martin <martin.dowie@btopenworld.com>]

On Mar 13, 4:31 pm, Tim Rowe <spamt...@tgrowe.plus.net> wrote:
> Alex R. Mosteo wrote:
> > While these are certainly important skills, one thing you should notice when
> > transitioning to Ada is a decreased need for access types thanks to
> > unconstrained/indefinite types. I'd think that would mean that you're in the
> > right track.
>
> But I can't put an unconstrained type into a record. I realise that I
> can make the record discriminated and constrain the type on the
> discriminant, trying to write a class that gives strtok-like
> functionality -- the excercise I have set myself at the moment -- means
> that I discover the sizes of relevant strings rather late in the game.
>
> > Anyway, if you have a sound knowledge of memory management in C/C++, it's
> > pretty much the same. Don't forget to deallocate, wrap it all in a
> > controlled type.
>
> What I'm feeling the lack of is destructors for classes (sorry, for
> tagged records). I suspect I'll find what I need when I learn about
> finalizers, but whereas in C++ I learned about delete at the same time
> as I learned about new, and I learned about destructors at the same time
> as I learned about constructors, it seems strange in Ada to find access
> allocation addressed in the mainstream and access deallocation relegated
> to an advanced topic (and destructors nowhere in my sight). And yet it's
> C/C++ that has the reputation for memory leaks!

This might help:

It's my implementation of the "Ada1Z" package
Ada.Containers.Indefinite_Holders (AI0069):

File: a-coinho.ads
--  The language-defined generic package Containers.Indefinite_Holders
--  provides private type Holder and a set of operations for that
type. A
--  holder container holds a single element of an indefinite type.
--
--  A holder containers allows the declaration of an object that can
be used
--  like an uninitialized variable or component of an indefinite type.
--
--  A holder container may be *empty*. An empty holder does not
contain an
--  element.

with Ada.Finalization;
with Ada.Streams;

generic
   type Element_Type (<>) is private;
   with function "=" (Left, Right : Element_Type) return Boolean is
<>;
   --  The actual function for the generic formal function "=" on
Element_Type
   --  values is expected to define a reflexive and symmetric
relationship and
   --  return the same result value each time it is called with a
particular
   --  pair of values. If it behaves in some other manner, the
function "=" on
   --  holder values returns an unspecified value. The exact arguments
and
   --  number of calls of this generic formal function by the function
"=" on
   --  holder values are unspecified.
   --
   --     AARM Ramification: If the actual function for "=" is not
symmetric
   --     and consistent, the result returned by any of the functions
defined
   --     to use "=" cannot be predicted. The implementation is not
required
   --     to protect against "=" raising an exception, or returning
random
   --     results, or any other "bad" behavior. And it can call "=" in
   --     whatever manner makes sense. But note that only the results
of the
   --     function "=" is unspecified; other subprograms are not
allowed to
   --     break if "=" is bad.
package Ada.Containers.Indefinite_Holders is
   pragma Preelaborate (Indefinite_Holders);
   --  This package provides a "holder" of a definite type that
contains a
   --  single value of an indefinite type.
   --  This allows one to effectively declare an uninitialized
variable or
   --  component of an indefinite type.

   type Holder is tagged private;
   pragma Preelaborable_Initialization (Holder);
   --  The type Holder is used to represent holder containers. The
type Holder
   --  needs finalization (see 7.6).

   Empty_Holder : constant Holder;
   --  Empty_Holder represents an empty holder object. If an object of
type
   --  Holder is not otherwise initialized, it is initialized to the
same
   --  value as Empty_Holder.

   function "=" (Left, Right : Holder) return Boolean;
   --  If Left and Right denote the same holder object, then the
function
   --  returns True.
   --  Otherwise, it compares the element contained in Left to the
element
   --  contained in Right using the generic formal equality operator,
   --  returning The Result of that operation. Any exception raised
during
   --  the evaluation of element equality is propagated.

   function To_Holder (New_Item : Element_Type) return Holder;
   --  Returns a non-empty holder containing an element initialized to
   --  New_Item.

   function Is_Empty (Container : Holder) return Boolean;
   --  Returns True if the holder is empty, and False if it contains
an
   --  element.

   procedure Clear (Container : in out Holder);
   --  Removes the element from Container.

   function Element (Container : Holder) return Element_Type;
   --  If Container is empty, Constraint_Error is propagated.
   --  Otherwise, returns the element stored in Container.

   procedure Replace_Element (Container : in out Holder;
                              New_Item  :        Element_Type);
   --  Replace_Element assigns the value New_Item into Container,
replacing
   --  any preexisting content of Container. Container is not empty
   --  after a successful call to Replace_Element.

   procedure Query_Element
     (Container :                 Holder;
      Process   : not null access procedure (Element : Element_Type));
   --  If Container is empty, Constraint_Error is propagated.
   --  Otherwise, Query_Element calls Process.all with the contained
element
   --  as the argument. Program_Error is raised if Process.all tampers
with
   --  the elements of Container. Any exception raised by Process.all
is
   --  propagated.

   procedure Update_Element
     (Container :                 Holder;
      Process   : not null access procedure (Element : in out
Element_Type));
   --  If Container is empty, Constraint_Error is propagated.
   --  Otherwise, Query_Element calls Process.all with the contained
element
   --  as the argument. Program_Error is raised if Process.all tampers
with
   --  the elements of Container. Any exception raised by Process.all
is
   --  propagated.

   procedure Move (Target : in out Holder;
                   Source : in out Holder);
   --  If Target denotes the same object as Source, then Move has no
effect.
   --  Otherwise, the element contained by Source (if any) is removed
from
   --  Source and inserted into Target, replacing any preexisting
content.
   --  Source is empty after a successful call to Move.

private

   type Element_Ptr is access Element_Type;

   type Holder is new Ada.Finalization.Controlled with record
      Contents : Element_Ptr := null;
      Busy     : Natural     := 0;
   end record;

   procedure Adjust (Container : in out Holder);

   procedure Finalize (Container : in out Holder);

   use Ada.Streams;

   procedure Write (Stream    : access Root_Stream_Type'Class;
                    Container :        Holder);
   for Holder'Write use Write;

   procedure Read (Stream    : access Root_Stream_Type'Class;
                   Container : out    Holder);
   for Holder'Read use Read;

   Empty_Holder : constant Holder := (Ada.Finalization.Controlled with
                                      others => <>);

end Ada.Containers.Indefinite_Holders;

File: a-coinho.adb
with Ada.Unchecked_Deallocation;
with System;

package body Ada.Containers.Indefinite_Holders is

   procedure Free is
     new Ada.Unchecked_Deallocation (Element_Type, Element_Ptr);

   ---------
   -- "=" --
   ---------

   function "=" (Left, Right : Holder) return Boolean is
      use type System.Address;
   begin
      if Left'Address = Right'Address then
         return True;
      end if;
      if Is_Empty (Left) then
         return Is_Empty (Right);
      else
         return not Is_Empty (Right) and then Left.Contents.all =
Right.Contents.all;
      end if;
   end "=";

   ---------------
   -- To_Holder --
   ---------------

   function To_Holder (New_Item : Element_Type) return Holder is
   begin
      return (Ada.Finalization.Controlled with
              Contents => new Element_Type'(New_Item),
              Busy     => 0);
   end To_Holder;

   --------------
   -- Is_Empty --
   --------------

   function Is_Empty (Container : Holder) return Boolean is
   begin
      return Container.Contents = null;
   end Is_Empty;

   -----------
   -- Clear --
   -----------

   procedure Clear (Container : in out Holder) is
   begin
      if Container.Busy > 0 then
         raise Program_Error with "attempt to tamper with element
(holder is busy)";
      end if;
      if Container.Contents /= null then
         Free (Container.Contents);
         Container.Busy := 0;
      end if;
   end Clear;

   -------------
   -- Element --
   -------------

   function Element (Container : Holder) return Element_Type is
   begin
      if Container.Contents = null then
         raise Constraint_Error with "Container has no element";
      end if;
      return Container.Contents.all;
   end Element;

   ---------------------
   -- 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 element
(holder is busy)";
      end if;
      Clear (Container);
      Container.Contents := new Element_Type'(New_Item);
   end Replace_Element;

   -------------------
   -- Query_Element --
   -------------------

   procedure Query_Element
     (Container :                 Holder;
      Process   : not null access procedure (Element : Element_Type))
is
      H : Holder  renames Container'Unrestricted_Access.all;
      B : Natural renames H.Busy;
   begin
      if Container.Contents = null then
         raise Constraint_Error with "Container has no element";
      end if;
      B := B + 1;
      begin
         Process (Container.Contents.all);
      exception
         when others =>
            B := B - 1;
            raise;
      end;
      B := B - 1;
   end Query_Element;

   --------------------
   -- Update_Element --
   --------------------

   procedure Update_Element
     (Container :                 Holder;
      Process   : not null access procedure (Element : in out
Element_Type)) is
      H : Holder  renames Container'Unrestricted_Access.all;
      B : Natural renames H.Busy;
   begin
      if Container.Contents = null then
         raise Constraint_Error with "Container has no element";
      end if;
      B := B + 1;
      begin
         Process (Container.Contents.all);
      exception
         when others =>
            B := B - 1;
            raise;
      end;
      B := B - 1;
   end Update_Element;

   ----------
   -- 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
(Target is busy)";
      end if;
      if Source.Busy > 0 then
         raise Program_Error with "attempt to tamper with elements
(Source is busy)";
      end if;
      if Target.Contents /= Source.Contents then
         Clear (Target);
         Target.Contents := Source.Contents;
         Source.Contents := null;
      end if;
   end Move;

   ------------
   -- Adjust --
   ------------

   procedure Adjust (Container : in out Holder) is
   begin
      if Container.Contents /= null then
         Container.Contents := new
Element_Type'(Container.Contents.all);
         Container.Busy     := 0;
      end if;
   end Adjust;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (Container : in out Holder) is
   begin
      if Container.Busy > 0 then
         raise Program_Error with "attempt to tamper with element
(holder is busy)";
      end if;
      if Container.Contents /= null then
         Free (Container.Contents);
         Container.Busy := 0;
      end if;
   end Finalize;

   -----------
   -- Write --
   -----------

   procedure Write (Stream    : access Root_Stream_Type'Class;
                    Container :        Holder) is
      Is_Present : constant Boolean := Container.Contents /= null;
   begin
      Boolean'Write (Stream, Is_Present);
      if Is_Present then
         Element_Type'Output (Stream, Container.Contents.all);
      end if;
   end Write;

   ----------
   -- Read --
   ----------

   procedure Read (Stream    : access Root_Stream_Type'Class;
                   Container : out    Holder) is
      Is_Present : Boolean := Boolean'Input(Stream);
   begin
      Clear (Container);
      if Is_Present then
         Container.Contents := new Element_Type'(Element_Type'Input
(Stream));
      end if;
   end Read;

end Ada.Containers.Indefinite_Holders;

Usual caveats about no warrenties, etc. but other than that use as you
see fit! :-)

Here's a (very) small test / demo:

File: test_ai05_0068.adb
--pragma Warnings (Off);
with Ada.Containers.Indefinite_Holders;
--pragma Warnings (On);
with Ada.Exceptions;
with Ada.Text_IO;

procedure Test_AI05_0069 is

   package String_Holders is
     new Ada.Containers.Indefinite_Holders (String);

   My_String : String_Holders.Holder := String_Holders.To_Holder
("Hello World!");

   procedure Test_Query is
      procedure Do_Something (Element : String) is
      begin
         My_String.Clear;
      end Do_Something;
   begin
      My_String.Query_Element (Do_Something'Access);
   exception
      when E : Program_Error =>
         Ada.Text_Io.Put_Line ("Caught exception [" &
Ada.Exceptions.Exception_Name (E)
                               & "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
   end Test_Query;

   procedure Test_Update is
      procedure Do_Something (Element : in out String) is
      begin
         My_String.Clear;
         Element := "asdasdas";
      end Do_Something;
   begin
      My_String.Update_Element (Do_Something'Access);
   exception
      when E : Program_Error =>
         Ada.Text_Io.Put_Line ("Caught exception [" &
Ada.Exceptions.Exception_Name (E)
                               & "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
   end Test_Update;

   procedure Test_Move is
      My_Other_String : String_Holders.Holder :=
String_Holders.To_Holder ("s");
   begin
      Ada.Text_IO.Put_Line ("Source = [" & My_String.Element & "]");
      Ada.Text_IO.Put_Line ("Target = [" & My_Other_String.Element &
"]");
      String_Holders.Move (Source => My_String,
                           Target => My_Other_String);
      begin
         Ada.Text_Io.Put_Line ("Source = [" & My_String.Element &
"]");
      exception
         when E : Constraint_Error =>
            Ada.Text_Io.Put_Line ("Caught exception [" &
Ada.Exceptions.Exception_Name (E)
                                  & "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
      end;
      Ada.Text_IO.Put_Line ("Target = [" & My_Other_String.Element &
"]");
   end Test_Move;

   type A_Record is record
      Component : String_Holders.Holder;
   end record;

   My_Record : A_Record;

begin
   Ada.Text_IO.Put_Line ("Is_Empty = " & Boolean'Image
(My_String.Is_Empty));
   My_String.Query_Element (Process => Ada.Text_IO.Put_Line'Access);
   Ada.Text_IO.Put_Line ("Element = [" & My_String.Element & "]");
   My_String.Replace_Element ("Wibble");
   My_String.Query_Element (Process => Ada.Text_Io.Put_Line'Access);
   Ada.Text_IO.Put_Line ("Element = [" & My_String.Element & "]");
   My_String.Clear;
   Ada.Text_Io.Put_Line ("Is_Empty = " & Boolean'Image
(My_String.Is_Empty));
   begin
      Ada.Text_Io.Put_Line ("Element = [" & My_String.Element & "]");
      Ada.Text_Io.Put_Line ("*** Should have raised exception");
   exception
      when E : Constraint_Error =>
         Ada.Text_Io.Put_Line ("Caught exception [" &
Ada.Exceptions.Exception_Name (E)
                               & "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
   end;
   My_String.Replace_Element ("Wibble again");
   Test_Query;
   Test_Update;
   Test_Move;
exception
   when E : others =>
      Ada.Text_Io.Put_Line ("Caught unexpected exception [" &
Ada.Exceptions.Exception_Name (E)
                            & "] with message [" &
Ada.Exceptions.Exception_Message (E) & "]");
end Test_AI05_0069;

Remember to include a '-a' options when you build it with GNAT.

Cheers
-- Martin