Override a procedure that recieves a class wide type as an argument in Ada

Question

I'm trying to understand how object oriented works in Ada. I have found a situation that I'm unable to resolve.

I know how to use class wide types for enabling polymorphism, and I know how to override a parent class' method from a derived one.

The thing I don't know how to do is to override a procedure that receives a class wide type as an argument, because I always obtain compilation errors. I explain this deeply below:

What I have tried

Type 1

package Pack1

    type Type1 is tagged
    record
        i : Integer := 20;
    end record;

    function get_number(self : Type1) return Integer;

    procedure do_something(self : Type1'class);

end Pack1;

----------------------------------------------------

package body Pack1 is 

    function get_number(self : Type1) return Integer is
    begin
        return 200;
    end get_number;

    procedure do_something(self : Type1'class) is
    begin
        Put_Line("Calling from Type1, " & (Integer'Image(self.i + self.get_number)));
    end do_something;

end Pack1;

Type 2

package Pack2

    type Type2 is new Type1 with
    record
        ii : Integer := 20;
    end record;

    overriding function get_number(self : Type2) return Integer;

    overriding procedure do_something(self : Type2'class);

end Pack2;

----------------------------------------------------

package body Pack2 is 

    function get_number(self : Type2) return Integer is
    begin
        return 300;
    end get_number;

    procedure do_something(self : Type2'class) is
    begin
        Put_Line("Calling from Type2, " & (Integer'Image(self.i + self.ii + self.get_number)));
    end do_something;

end Pack2;

Main

procedure Main is
    t1 : Type1;
    t2 : Type2;
begin
    t1.do_something;
    t2.do_something;
end Main;

Obtained error

I obtain an error during compilation time:

possible interpretation at Type1.ads
possible interpretation at Type2.ads

Expected output

I'm expecting to obtain the following, when I can compile the code:

Calling from Type1, 220

Calling from Type2, 350

How can I achieve the behavior I want?

Answer 1

The problem is you are trying to use class types a bit too early. You want your Do_Something procedures to take an input of Type1 and Type2, not Type1'Class or Type2'Class. Then you can call those procedures from within another one that takes a class type parameter (which will give you your polymorphism).

Jacob Sparre Andersen showed you this in his answer, but I wanted to gen up something closer to your original code as an extra reference.

Below is a test program based on your original (compiled in the jdoodle online compiler) that shows the various ways to call the function polymorphically.

Code:

with Ada.Text_IO; use Ada.Text_IO;

procedure jdoodle is

    package Pack1 is

        type Type1 is tagged
        record
            i : Integer := 20;
        end record;

        type Type1_Class_Access is access all Type1'Class;

        function get_number(self : Type1) return Integer;

        procedure do_something(self : Type1);  -- note the change here

    end Pack1;

    ----------------------------------------------------

    package body Pack1 is 

        function get_number(self : Type1) return Integer is
        begin
            return 200;
        end get_number;

        procedure do_something(self : Type1) is  -- note the change here
        begin
            Put_Line("Calling from Type1, " & (Integer'Image(self.i + self.get_number)));
        end do_something;

    end Pack1;

    package Pack2 is

        use Pack1;

        type Type2 is new Type1 with
        record
            ii : Integer := 20;
        end record;

        overriding function get_number(self : Type2) return Integer;

        overriding procedure do_something(self : Type2);  -- note the change here

    end Pack2;

    ----------------------------------------------------

    package body Pack2 is 

        function get_number(self : Type2) return Integer is
        begin
            return 300;
        end get_number;

        procedure do_something(self : Type2) is
        begin
            Put_Line("Calling from Type2, " & (Integer'Image(self.i + self.ii + self.get_number)));
        end do_something;

    end Pack2;


    t1 : aliased Pack1.Type1;
    t2 : aliased Pack2.Type2;

    p1 : Pack1.Type1'Class := Pack1.Type1'(others => <>);
    p2 : Pack1.Type1'Class := Pack2.Type2'(others => <>);

    procedure Do_Something(Object : Pack1.Type1'Class) is
    begin
        Object.Do_Something;  -- polymorphically calls Do_Something
    end Do_Something;

    type Class_Array is array(Integer range <>) of Pack1.Type1_Class_Access;

    a : Class_Array(1..2) := (1 => t1'Access, 2 => t2'Access);

begin
    -- Non Polymorphic calls
    t1.do_something;
    t2.do_something;

    -- Polymorphic variable calls
    -- both variables are of type Pack1.Type1'Class
    p1.do_something;
    p2.do_something;

    -- Polymorphic procedure calls
    -- the input type of the procedure is Pack1.Type1'Class
    Do_Something(t1);
    Do_Something(t2);

    -- Polymorphic array of class access variable calls
    for e of a loop
        e.Do_Something;
    end loop;
    for e of a loop
        Do_Something(e.all);
    end loop;
end jdoodle;

Output:

Calling from Type1,  220
Calling from Type2,  340
Calling from Type1,  220
Calling from Type2,  340
Calling from Type1,  220
Calling from Type2,  340
Calling from Type1,  220
Calling from Type2,  340
Calling from Type1,  220
Calling from Type2,  340

Answer 2

As Jacob said in this answer, you can’t override Do_Something because it’s not primitive, because its controlling parameter is classwide.

If you remove Pack2.Do_Something altogether, your program will compile. However, the output is

$ ./main
Calling from Type1,  220
Calling from Type1,  320

which is getting closer to what you want.

A better solution would be to eliminate ’Class in Pack2.Do_Something, which makes it a primitive (dispatchable) operation.

I still don’t get the result you want:

$ ./main
Calling from Type1,  220
Calling from Type2,  340

Perhaps you meant to initialise Pack2.Type2.ii to 30?

(By the way, the code you posted doesn’t compile. Please make it easier for us to help you by submitting compilable examples!)

Answer 3

Subprograms taking class-wide arguments are not primitive operations of the parent of the class, and can thus not be inherited.

If a subprogram takes a class-wide argument, the point is that its implementation is written in term of operations defined for the parent of the class. If you want to change its behaviour for a derived type, you do it by overriding the relevant primitive operations of the derived type.

Specifications:

package A is
   type Values is range 0 .. 999;

   type Instance is tagged private;
   subtype Class is Instance'Class; --'

   function Name       (Item : in Instance) return String;
   function Get_Number (Item : in Instance) return Values;
   function Get_Sum    (Item : in Instance) return Values;
private
   type Instance is tagged
      record
         First : Values := 20;
      end record;
end A;

with A;

package B is
   subtype Parent is A.Instance;
   type Instance is new Parent with private;
   subtype Class is Instance'Class; --'

   overriding
   function Name       (Item : in Instance) return String;
   overriding
   function Get_Number (Item : in Instance) return A.Values;
   overriding
   function Get_Sum    (Item : in Instance) return A.Values;
private
   type Instance is new Parent with
      record
         Second : A.Values := 20;
      end record;
end B;

with Ada.Text_IO;

with A;

procedure Do_Something (Item : in A.Class);

Implementations:

package body A is
   function Name       (Item : in Instance) return String is ("Class A");
   function Get_Number (Item : in Instance) return Values is (200);
   function Get_Sum    (Item : in Instance) return Values is (Item.First);
end A;

package body B is
   use all type A.Values;

   overriding
   function Name       (Item : in Instance) return String   is ("Class B");
   overriding
   function Get_Number (Item : in Instance) return A.Values is (300);
   overriding
   function Get_Sum    (Item : in Instance) return A.Values is (Parent (Item).Get_Sum + Item.Second);
end B;

procedure Do_Something (Item : in A.Class) is
   use all type A.Values;
begin
   Ada.Text_IO.Put_Line
      ("Calling from " & Item.Name & ", " & A.Values'Image (Item.Get_Number + Item.Get_Sum));
end Do_Something;

And finally a demonstrator:

with A;
with B;
with Do_Something;

procedure Inheritance_Demo_2018_06_13 is
   O : A.Instance;
   P : B.Instance;
begin
   Do_Something (O);
   Do_Something (P);
end Inheritance_Demo_2018_06_13;