How to return a copy of a class wide object with a modification to the base type in Ada

Question

I have a base type whose job is to maintain a list of items. It has a non-dispatching function to add items to it, as well as to retrieve the list of items from it.

The types derived from this base type make use of the items in some dispatching subprograms. I can already implement this by having the base type contain a vector of the items, however I would like to have the array be static if possible. This is what I have so far:

bases.ads:

package Bases is
    type Base (<>) is tagged private; -- I want to hide the size
    type Int_List is array (Positive range <>) of Integer; -- as an example

    function Create return Base; -- returns an empty Base

    function Add_To (This : Base'Class; I : Integer) return Base'Class; -- Append
    function Image (This : Base) return String; -- Dispatching example
    function List (This : Base'Class) return Int_List; -- Get the data for internal use
private
    type Base (Size : Natural) is tagged record
        Ints : Int_List (1 .. Size);
    end record;
end Bases;

bases.adb:

package body Bases is
    function Create return Base is (Size => 0, Ints => (others => 0));
    function Add_To (This : Base'Class; I : Integer) return Base'Class is
        -- This is where I have trouble: "aggregate cannot be of a class-wide type"
        Copy : Base'Class := (This with Size => This.Size + 1, Ints => This.Ints & I);
    begin
        return Copy;
    end Add_To;
    function Image (This : Base) return String is ("BASE");
    function List (This : Base'Class) return Int_List is (This.Ints);
end Bases;

deriveds.ads:

with Bases;
package Deriveds is
    type Derived is new Bases.Base with null record;
    function Create return Derived;
    function Image (This : Derived) return String;
end Deriveds;

deriveds.adb:

with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package body Deriveds is
    function Create return Derived is (Bases.Create with null record);
    function Image (This : Derived) return String is
        Result : Unbounded_String;
        Ints : Bases.Int_List := This.List;
    begin
        for I in Ints'Range loop
            Result := Result & Integer'Image (Ints (I));
        end loop;

        return To_String (Result);
    end Image;
end Deriveds;

Again, I'm aware that if I just remove the discriminant and use a controlled type to store the array then I can just create the copy as Copy : Base'Class := This; and mutate it before returning it. However, I feel like there should be a way to do this with only static memory, which is desireable. The only other workaround I could think of would be to create another tagged type which would be a record containing the list and the Base'Class data and whose operations would shadow the Base dispatching operations, passing them through.

Is there no way to create the Copy in Add_To such that its discriminant is 1 larger and has an extra element using only static memory?

Answer 1

I know it requires a bit more work, but you can also Change Add_To to use Base instead of Base'Class. You then have to override it for any derived types with more than a null record extension, but you would get the desired static array result. The derived implementations would be similar to how you implement Create.

Example (I modified the derived class to have a non null record extension to force the compiler to require you to derive the operation:

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

procedure Hello is

    package Bases is
        type Base (<>) is tagged private; -- I want to hide the size
        type Int_List is array (Positive range <>) of Integer; -- as an example

        function Create return Base; -- returns an empty Base

        function Add_To (This : Base; I : Integer) return Base; -- Append
        function Image (This : Base) return String; -- Dispatching example
        function List (This : Base'Class) return Int_List; -- Get the data for internal use
    private
        type Base (Size : Natural) is tagged record
            Ints : Int_List (1 .. Size);
        end record;
    end Bases;

    package body Bases is
        function Create return Base is (Size => 0, Ints => (others => 0));
        function Add_To (This : Base; I : Integer) return Base is
            -- This is where I have trouble: "aggregate cannot be of a class-wide type"
            Copy : Base := (Size => This.Size + 1, Ints => This.Ints & I);
        begin
            return Copy;
        end Add_To;
        function Image (This : Base) return String is ("BASE");
        function List (This : Base'Class) return Int_List is (This.Ints);
    end Bases;

    package Deriveds is
        type Derived is new Bases.Base with  record
            Value : Integer;
        end record;
        function Create return Derived;
        function Add_To(This : Derived; I : Integer) return Derived;
        function Image (This : Derived) return String;
    end Deriveds;

    package body Deriveds is
        function Create return Derived is (Bases.Create with Value => 0);
        function Image (This : Derived) return String is
            Result : Unbounded_String;
            Ints : Bases.Int_List := This.List;
        begin
            for I in Ints'Range loop
                Result := Result & Integer'Image (Ints (I));
            end loop;

            return To_String (Result);
        end Image;
        function Add_To(This : Derived; I : Integer) return Derived is
        begin
            return (Bases.Base(This).Add_To(I) with Value => This.Value);
        end Add_To;
    end Deriveds;

    use Deriveds;

    d0 : Derived := Create;
    d1 : Derived := d0.Add_To(1).Add_To(3);
    d2 : Derived := d1.Add_To(2);

begin
  Put_Line(d2.Image);
end Hello;

Answer 2

I think the trouble is that Bases.Add_To has no pleasant, standard way to know what to append to the Base record (with Size incremented) to replicate the actual class-specific data in This.

I suppose you could muck around with unchecked conversion & construct the record by using, perhaps, Ada.Tags.Generic_Dispatching_Constructor (here, here); but it seems like a Bad Idea.