package body Safe_Pointers.On_Definite_Types is

  function Null_Pointer return Safe_Pointer is
  begin
    return (Ada.Finalization.Controlled with
            Track => Null_Track);
  end Null_Pointer;

  function "=" (Left, Right: Safe_Pointer) return Boolean is
  begin
    return Left.Track.Object = Right.Track.Object;
  end "=";

  procedure Adjust (Pointer: in out Safe_Pointer) is
  begin
   if Pointer.Track /= Null_Track then
      Pointer.Track.Count := Pointer.Track.Count + 1;
    end if;
  end Adjust;

  procedure Finalize (Pointer: in out Safe_Pointer) is
  begin
    if Pointer.Track /= Null_Track then
      Pointer.Track.Count := Pointer.Track.Count - 1;
      if Pointer.Track.Count = 0 then  -- last pointer
        if Pointer.Track.Pool_Element then
          Free (Pointer.Track.Object);
        end if;
        Free (Pointer.Track);
      end if;
    end if;
  end Finalize;

  procedure Allocate (Pointer: in out Safe_Pointer) is
  begin
    Finalize (Pointer);
    Pointer.Track := new Track'(new Object, 1, Pool_Element => True);
  end Allocate;

  procedure Allocate (Pointer: in out Safe_Pointer; Value: in Object) is
  begin
    Finalize (Pointer);
    Pointer.Track := new Track'(new Object'(Value), 1, Pool_Element => True);
  end Allocate;

  procedure Deallocate (Pointer: in out Safe_Pointer) is
  begin
    if Pointer.Track = Null_Track then
      return;
    end if;
    if Pointer.Track.Pool_Element then
      Free (Pointer.Track.Object);
    end if;
    Pointer.Track.Count := Pointer.Track.Count - 1;
    if Pointer.Track.Count = 0 then  -- last pointer
      Free (Pointer.Track);
    end if;
    Pointer.Track := Null_Track;
  end Deallocate;

  procedure Assign (Pointer: in Safe_Pointer; Value: in Object) is
  begin
    Pointer.Track.Object.all := Value;
  end Assign;

  function Value (Pointer: Safe_Pointer) return Object is
  begin
    return Pointer.Track.Object.all;
  end Value;

  procedure Alias (Pointer: in out Safe_Pointer; Value : access Object) is
  begin
    Finalize (Pointer);
    Pointer.Track := new Track'(Object_Pointer (Value), 1, Pool_Element => False);
  end Alias;

end Safe_Pointers.On_Definite_Types;

Back to text.