Check for null object in "=" function

Question

I want to write a "=" function, which can compare an A_Access also against the null object. How do I need to write the "=" function, so that it works? For my try, see below.

The code produces a raised CONSTRAINT_ERROR : main.adb:14 access check failed.

with Ada.Tags;
with Ada.Text_IO;

procedure Main is
   type A is tagged
      record
         a : Integer;
      end record;
   type A_Access is access all A'Class;

   function "=" (Left, Right : A_Access) return Boolean is
      use Ada.Tags;
   begin
      return (Left.all'Tag = Right.all'Tag and then Left.a = Right.a);
   end "=";
begin
   declare
      A_1 : A_Access := new A'(a => 1);
      A_2 : A_Access := null;
   begin
      if A_1 /= A_2 then
         Ada.Text_IO.Put_Line (":-)");
      end if;
   end;
end Main;

I also tried to check for null, but then, I get raised STORAGE_ERROR : stack overflow. I think, here happens an infinite recursion?

function "=" (Left, Right : A_Access) return Boolean is
   use Ada.Tags;
begin
   if null = Left or null = Right then
      return False;
   else
      return (Left.all'Tag = Right.all'Tag and then Left.a = Right.a);
   end if;
end "=";

Answer 1

When you define the type A_Access, the compiler automatically defines an equality operator for you:

function "=" (Left, Right : A_Access) return Boolean; --built-in function

When you define your own, though:

function "=" (Left, Right : A_Access) return Boolean is

Right after the is keyword, your new function becomes visible, and any time you use it on two operands of type A_Access, it will call your new function--including inside the body of your function. That means that the line

if null = Left or null = Right then

will call your "=" recursively, leading to a stack overflow.

To get around this, you can rename the built-in function before you define your own "=":

type A_Access is access all A'Class;
-- the following declaration is implicitly added by the compiler
--function "=" (Left, Right : A_Access) return Boolean; --built-in function
function Builtin_Equal (Left, Right : A_Access) return Boolean renames "=";

Since your new "=" isn't visible at that point, renames "=" will rename the built-in function. Now you can use your new name:

function "=" (Left, Right : A_Access) return Boolean is
   use Ada.Tags;
begin
   if Builtin_Equal (null, Left) or else Builtin_Equal (null, Right) then
      return False;  -- THIS IS WRONG!
   else
      return (Left.all'Tag = Right.all'Tag and then Left.a = Right.a);
   end if;
end "=";

(I changed or to or else because it's my preference, and because it will sometimes save a little bit of time if the code doesn't have to evaluate both operands. It doesn't matter much.)

Also, do you really want your "=" to return False if both sides are null? Try this instead:

function "=" (Left, Right : A_Access) return Boolean is
   use Ada.Tags;
begin
   if Builtin_Equal (null, Left) or else Builtin_Equal (null, Right) then
      return Builtin_Equal (Left, Right);
   else
      return (Left.all'Tag = Right.all'Tag and then Left.a = Right.a);
   end if;
end "=";

which returns true if both are null, false if either one is null but not both, and otherwise it will check your tag and a component. Another way to do it, which is a little more efficient if Left and Right happen to be the exact same pointer:

function "=" (Left, Right : A_Access) return Boolean is
   use Ada.Tags;
begin
   if Builtin_Equal (Left, Right) then
      return true;
   elsif Builtin_Equal (null, Left) or else Builtin_Equal (null, Right) then
      return false;
   else
      return (Left.all'Tag = Right.all'Tag and then Left.a = Right.a);
   end if;
end "=";

Answer 2

I'm not very good at Ada, but here is what I know: Your overloading is of course used when you compare the access parameter to null. I dont remember whether there is such a thing as "access to the baseclass version" (using C++ terminology here) but what you are essentially trying to do is compare two pointers and not two records. That's what your overloading of "=" is saying and thats why you get a recursion.

Perhaps you should write a function like Is_Equal()

with access types and leave the predefined equality operator untouched.

Answer 3

A while back I answered a similar question "How can I overload the '=' operator in Ada without creating a recursive function?", though it didn't deal with classwide parameters.

You can use the same technique:

  Type Class_Access is Access WHATEVER'CLASS;

  Function "=" (Left, Right: IN Class_Access) Return Boolean is

     Function Is_Equal( Left : Class_Access; Right : WHATEVER'CLASS ) Return Boolean is
     begin
        Return Right = Left.All;
     exception
        When CONSTRAINT_ERROR => Return False;
     end Is_Equal;

  Begin
     Return Is_Equal(Left, Right.All);
  Exception
     When CONSTRAINT_ERROR =>
        begin
           Return Is_Equal(Right,Left.All);
        Exception
           When CONSTRAINT_ERROR => Return True;
        end;
  End "=";

Though perhaps using a combination of ajb's answer and Ada.Tags.Is_Descendant_At_Same_Level would be a better solution.