I'm implementing a visitor pattern and I have some elements that I could implement using generics, but the GNAT compiler complains with the generic type. I have a solution using generic mix-ins but its less intuitive.

How can I solve it?

I provide the following minimal reproducibable example:

1. visitors.ads

with ConcreteElements;
with Instantiation;

package Visitors is

  type Visitor_t is interface;

  procedure pVisit (this : in Visitor_t;
                    element : ConcreteElements.ConcreteElement_t) is abstract;

  procedure pVisit (this : in Visitor_t;
                    element : Instantiation.GenericElement_t) is abstract;

end Visitors;

2. elements.ads

limited with Visitors;

package Elements is

  type Element_t is abstract tagged null record;

  procedure pAccept
    (this : in Element_t;
     visitor : in Visitors.Visitor_t'Class) is abstract;

end Elements;

3. concreteelements.ads/adb

limited with Visitors;
with Elements;

package ConcreteElements is

  type ConcreteElement_t is new Elements.Element_t with null record;

  overriding
  procedure pAccept
    (this : in ConcreteElement_t;
     visitor : in Visitors.Visitor_t'Class);

end ConcreteElements;

with Visitors;

package body ConcreteElements is

  procedure pAccept
    (this : in ConcreteElement_t;
     visitor : in Visitors.Visitor_t'Class) is
  begin
    visitor.pVisit(this);
  end pAccept;

end ConcreteElements;

4. genericelements.ads/adb

with Elements;
limited with Visitors;

generic
  type Parent_t (<>) is abstract new Elements.Element_t with private;
package GenericElements is

  type GenericElement_t is new Parent_t with null record;

  overriding
  procedure pAccept (this : in GenericElement_t;
                     visitor : in Visitors.Visitor_t'Class);

end GenericElements;

with Visitors;

package body GenericElements is

  procedure pAccept (this : in GenericElement_t;
                     visitor : in Visitors.Visitor_t'Class) is
  begin
    visitor.pVisit(this);
  end pAccept;

end GenericElements;

5. instantiation.ads

with GenericElements;
with Elements;

package instantiation is new GenericElements
  (Parent_t => Elements.Element_t);

The compiler complains in the body of 4), at line 9:

expected type "instantiation.GenericELement_t" defined at genericelements.ads:8

found type "GenericElements.GenericElement_t" defined at genericelements.ads:8

My solution is to perform a mix-in, making GenericElement_t abstract, thus this would be 1), 4) and 5):

1)

with ConcreteElements;
with Instantiation;

package Visitors is

  type Visitor_t is interface;

  procedure pVisit (this : in Visitor_t;
                    element : ConcreteElements.ConcreteElement_t) is abstract;

  procedure pVisit (this : in Visitor_t;
                    element : Instantiation.Instantiation_t) is abstract;

end Visitors;

with Elements;

generic
  type Parent_t (<>) is abstract new Elements.Element_t with private;
package GenericElements is

  type GenericElement_t is abstract new Parent_t with null record;

end GenericElements;

private with GenericElements;
limited with Visitors;
with Elements;

package instantiation is 

  type Instantiation_t is new Elements.Element_t with private;

  overriding
  procedure pAccept (this : in Instantiation_t;
                     visitor : Visitors.Visitor_t'Class);

private

  package instantiation_pck is new GenericElements 
    (Parent_t => Elements.Element_t);

  type Instantiation_t is new instantiation_pck.GenericElement_t with null record;

end instantiation;

with Visitors;

package body instantiation is

  procedure pAccept (this : in Instantiation_t;
                     visitor : Visitors.Visitor_t'Class) is
  begin
    visitor.pVisit(this);
  end pAccept;


end instantiation;

Can I implement correctly the first option or I shall implement it using mix-ins?

Thank you in advance and sorry for the ammount of code.

I'm trying to implement an Observer pattern using OOP and dynamic dispatching, but I'm not able to create an access-to-subprogram constant because the argument types of the named access and the procedure of the type extension don't match.

I provide a minimal reproducibable example, ommiting subscription:

package Alarms is

  type time_t is mod 2**32;

  type AlarmObserver_t is interface;
  type Callback_t is access procedure (this : in out AlarmObserver_t);

  type AlarmPublisher_t (<>) is tagged limited private;
  function fConstructor (capacity : in Positive) return AlarmPublisher_t;

private

  type AlarObserverAcc_t is access AlarmObserver_t'Class;

  type dummy_t is new AlarmObserver_t with null record;
  procedure pEventDummy (this : in out dummy_t) is Null;

  dummy : constant AlarObserverAcc_t := new dummy_t;
  dummyCallback : constant Callback_t := pEventDummy'Access; --Fails

  type Node_t is limited
    record
      Observer : AlarObserverAcc_t := dummy;
      Callback : Callback_t := dummyCallback;
      time : time_t := time_t'Last;
    end record;

  defaultNode : constant Node_t := Node_t' (Observer => dummy,
                                            Callback => dummyCallback,
                                            time     => time_t'Last);

  type ObserverArray_t is array (Positive range <>) of Node_t;

  type AlarmPublisher_t (capacity : Positive) is tagged limited 
    record
      --Member "observers" has default initialisation because Node_t is initialised
      observers : ObserverArray_t (Positive'First .. capacity);
    end record;

end Alarms;

And the implementation to let you reproduce it:

package body Alarms is
  
  function fConstructor (capacity : in Positive) return AlarmPublisher_t is
  begin
    return Obj : AlarmPublisher_t (capacity => capacity) do
      Null;
    end return;
  end fConstructor;

end Alarms;

I was inspiring in Matthew Heaney callbacks Observer pattern

He use a class-wide argument for the access-to-subprogram procedure, but I would like to use OOP notation and let the concrete observers to have those procedures as primitives.

Why procedure pEventDummy is not compatible if dummy_t implements AlarmObserver_t interface? Can I do what I want?

I provide an example below to show what I would like to do. I want concrete observers to be flexible and allow them to subscribe to the method they want to be notified when the subscribed alarm expires. I don't know in advance which primitives will be used for that purpose so I don't want to type all the possibilities as abstract primitives of the AlarmObserver_t interface, I would like let the concrete observers to subscribe to an access to procedure for that purpose, and they will be notified through them at different moments:

with Alarms;

package ConcreteObserver is

  type ConcreteObserver_t is new Alarms.AlarmObserver_t with private;

  --Procedure evTimeout to be notified for an alarm expirancy.
  --Null implementation to let you compile
  procedure evTimeout (this : in out ConcreteObserver_t) is null;

  --Procedure evAnotherTimeout to be notified for another alarm expirancy
  --Null implementation to let you compile
  procedure evAnotherTimeout (this : in out ConcreteObserver_t) is null;

private

  --This will fail as dummyCallback in Alarms package
  evTimeoutCallback : constant Alarms.Callback_t := evTimeout'Access; 

  --This will fail as dummyCallback in Alarms package
  evAnotherTimeoutCallback : constant Alarms.Callback_t := evAnotherTimeout'Access; 

  type ConcreteObserver_t is new Alarms.AlarmObserver_t with 
    record
      --Any attribute
      Null;
    end record;


end ConcreteObserver;

I'm using an instance of package Ada.Containers.Formal_Indefinite_Vectors to store two kinds of polimorphic objects.

I have the following package where I instantiate the container:

with Interfaces.C;
with Root.Classes.Concrete_1;
with Root.Classes.Concrete_2;

package Root.Vectors is

  type vector_t is tagged limited private;
  subtype vectorIndex_t is Interfaces.C.int range 1 .. Interfaces.C.int'Last;

  procedure pAppend (this : in out vector_t;
                     New_Item : Root.Classes.Parent_t'Class);

  procedure pClear (this : in out vector_t);

private
  --TODO: I have to define it correctly, it could be the problem
  function "=" (Left, Right : Root.Classes.Parent_t'Class)
                return Boolean is (True); 

  MaxSize : constant Natural := Natural'Max 
    (Root.Classes.Concrete_1.Concrete_1_t'Size,
     Root.Classes.Concrete_2.Concrete_2_t'Size);

  package polimorphicVector_pck is new
    Ada.Containers.Formal_Indefinite_Vectors
      (Index_Type                   => vectorIndex_t,
       Element_Type                 => Root.Classes.Parent_t'Class,
       "="                          => "=",
       Max_Size_In_Storage_Elements => MaxSize,
       Bounded                      => True);

  type vector_t is tagged limited
    record
      v : polimorphicVector_pck.Vector (Capacity => 1000); --TODO: magic number
    end record;

end Root.Vectors;

package body Root.Vectors is

  procedure pAppend (this : in out vector_t;
                     New_Item : Root.Classes.Parent_t'Class) is

  begin
    polimorphicVector_pck.Append (Container => this.v,
                                  New_Item  => New_Item);
  end pAppend;

  procedure pClear (this : in out vector_t) is

  begin
    polimorphicVector_pck.Clear (Container => this.v);
  end pClear;

end Root.Vectors;

Then I test it with the following main:

with Root.Classes.Concrete_1;
with Root.Vectors;

procedure Main is

  aVector : Root.Vectors.Vector_t;

begin

  for idx in Natural range 1 .. 1000 loop

    declare
      --Concrete_1_t is an unconstrained tagged type that requires constructor
      obj : Root.Classes.Concrete_1.Concrete_1_t :=
        Root.Classes.Concrete_1.fConstructor (Argument => idx);
    begin
      aVector.pAppend (New_Item => obj);
    end;

  end loop;

  -- Trying to clear the vector after all appends; this does not seem to work
  aVector.pClear;

end Main;

Then, I have used gnatmem to check if I have any memory leak, showing the following:

Global information
------------------
   Total number of allocations        :779831
   Total number of deallocations      :5080
   Final Water Mark (non freed mem)   : 26.71 Megabytes
   High Water Mark                    : 26.71 Megabytes

Allocation Root # 1
-------------------
 Number of non freed allocations    :764550
 Final Water Mark (non freed mem)   : 17.50 Megabytes
 High Water Mark                    : 17.50 Megabytes
 Backtrace                          :
   ??:0 ??

Allocation Root # 2
-------------------
 Number of non freed allocations    :5100
 Final Water Mark (non freed mem)   : 119.53 Kilobytes
 High Water Mark                    : 119.53 Kilobytes
 Backtrace                          :
   a-cfinve.adb:220 root.vectors.polimorphicVector_pck.copy

Allocation Root # 3
-------------------
 Number of non freed allocations    :3390
 Final Water Mark (non freed mem)   : 7.78 Megabytes
 High Water Mark                    : 7.78 Megabytes
 Backtrace                          :
   a-cfinve.adb:466 root.vectors.polimorphicVector_pck.find_index

Allocation Root # 4
-------------------
 Number of non freed allocations    :1710
 Final Water Mark (non freed mem)   : 1.32 Megabytes
 High Water Mark                    : 1.32 Megabytes
 Backtrace                          :
   a-cfinve.adb:219 root.vectors.polimorphicVector_pck.copy

Allocation Root # 5
-------------------
 Number of non freed allocations    :   1
 Final Water Mark (non freed mem)   : 8 Bytes
 High Water Mark                    : 8 Bytes
 Backtrace                          :
   ??:0 system.stream_attributes.xdr.i_ssi

Why is it leaking? It can be due to the "=" that always return True?

Can I compile a library adding a namespace at compile time using GNAT? I have to link to a legacy library that don't use a root package and child packages, so it's very annoying having hundred of options when I have to include something.

The other option I have is to write a Python script to add the root package to all files to reduce the problem.

I am using the Ada library gnatcoll.sql to create parametrizable SQL queries.

While I am able to create Integer parameters for type SQL_Field_Integer using the function:

function Integer_Param (Index : Positive) return Integer_Fields.Field'Class
  renames Integer_Fields.Param;

As well as for the following types using their respective functions:

SQL_Field_Bigint, SQL_Field_Text, SQL_Field_Boolean, SQL_Field_Float, SQL_Field_Long_Float, SQL_Field_Money, SQL_Field_Time, SQL_Field_Date

I am not able to parametrize Blob fields, I don't find those type mappings nor any service except the postgresql/sqlite bindings at low-level.

How can I parametrize blob types? As String?

I'm using GNATColl-sql to create SQL queries. I was thinking to perform a visual inspection of the generated SQL code using the "To_String" method, but when I call Ada.Text_IO.Put_Line or Ada.Text_IO.Put to see the SQL string, a carriage return is being added to the output.

For example, I cannot share the real query, if I expect:

SELECT orders.order_id, customers.last_name FROM orders INNER JOIN customers ON orders.customer_id = customers.customer_id WHERE orders.order_id <> 1 ORDER BY orders.order_id;

What I'm getting after Put_Line/Put instead (notice the line break at customers.cust CRLF omer_id):

SELECT orders.order_id, customers.last_name FROM orders INNER JOIN customers ON orders.customer_id = customers.cust
omer_id WHERE orders.order_id <> 1 ORDER BY orders.order_id;

I first suspected that carriage return was due to a GNATColl-sql bug, but now I suspect the procedure Ada.Text_IO.Put_Line has a maximum line length to print. Am I right?

I tried the procedure "Ada.Text_IO.Set_Line_Length" with a huge count value, greater than the position where the carriage return is added, but it is printed at the same place.

How can I print a large string on a line instead of several lines?

New suspicion:

I was running my main on GNATStudio, but if I directly run the main.exe on a cmd I can see the SQL on a line now. GNATStudio may be configuring a maximum line length for printing.