I want to use a C++ library that implements the Factory Method design pattern.

Below you can see a minimal reproducibable example, including C++ sources and the Ada adapter.

• Item.h:

  // Product interface
  
  #ifndef _ITEM_H_
  #define _ITEM_H_
  
  class Item {
  public:
  
    virtual ~Item() = default;
    virtual void do_something() = 0;
  };
  
  #endif
  

• ConcreteItem.h:

  
  #ifndef _CONCRETEITEM_H_
  #define _CONCRETEITEM_H_
  
  #include "Item.h"
  
  class ConcreteItem : public Item {
  public:
    ConcreteItem();
    ~ConcreteItem();
    void do_something();
  };
  
  #endif
  

• ConcreteItem.cpp:

  
  #include <stdlib.h>
  #include <iostream>
  #include "ConcreteItem.h"
  
  void ConcreteItem::do_something() {
    std::cout << "Doing stuff \n";
  };
  
  ConcreteItem::ConcreteItem() {
    std::cout << "Concrete Item created \n";
  };
  
  ConcreteItem::~ConcreteItem(){
    std::cout << "Concrete Item destroyed \n";
  };
  

• Factory.h:

  
  #ifndef _FACTORY_H_
  #define _FACTORY_H_
  
  #include "Item.h"
  
  class Factory {
  public:
    static Item* get_configured_item ();
    Factory(Factory& other) = delete;
  
  private:
  
    static Factory* factory;
    static Item* config_item;
  
    Factory();
    ~Factory();
  };
  
  #endif
  

• Factory.cpp:

  
  #include "Factory.h"
  #include "ConcreteItem.h"
  
  Factory* Factory::factory = nullptr;
  Item* Factory::config_item = nullptr;
  
  Item *Factory::get_configured_item() {
  
    if (Factory::factory == nullptr) {
      Factory::factory = new Factory();
  
      if (Factory::config_item == nullptr) {
        Factory::config_item = new ConcreteItem();
      };
    };
  
    return Factory::config_item;
  };
  
  Factory::Factory(){};
  Factory::~Factory() {
    delete Factory::config_item;
  };
  

And here I have the Ada files that imports C++ symbols, generated with a call to g++ -c -fdump-ada-spec -C ./Factory.h and doing some modifications to suite my taste:

• Factory_h.ads:

  limited with Item_h;
  
  package Factory_h is
  
    type Factory is limited record
      null;
    end record
      with Import => True,
      Convention => CPP;
  
    function get_configured_item return access Item_h.Item'Class  -- ./Factory.h:9
      with Import => True, 
      Convention => CPP, 
      External_Name => "_ZN7Factory19get_configured_itemEv";
  
  end Factory_h;
  

• Item_h.ads:

  
  with Interfaces.C;
  
  package Item_h is
    type Item is limited interface
      with Import => True,
      Convention => CPP;
  
    --  procedure Delete_Item (this : access Item) is abstract;-- ./Item.h:8
    --  
    --  procedure Delete_And_Free_Item (this : access Item) is abstract; -- ./Item.h:8;
  
    procedure do_something (this : access Item) is abstract;  -- ./Item.h:9
  end Item_h;
  

And finaly an Ada main to test this silly example:

with Factory_h;
with Item_h;

procedure main is
  
  configured_item : constant access Item_h.Item'Class :=
    Factory_h.get_configured_item;
  
begin
  
  configured_item.do_something;

end main;

Do you know why if I comment out the Item primitives Delete_Item and Delete_And_Free_Item the call to do_something is never done and the item is destroyed?

If I uncomment them everything works.

Thanks in advance!

I'm facing now the following weird run-time error:

raised PROGRAM_ERROR : s-finroo.adb:42 explicit raise

I'm trying to implement an Observer design pattern. Since my observers are limited and I want to avoid general access types, I'm storing the observers' address and notifying them using Ada.Adress_To_Access_Conversions. My concrete observers are inheriting from Ada.Finalization.Limited_Controlled as I have to initialize and finalize them somehow as per my implementation. Take a look at components.ads below, where Component_t is defined.

I leave you a minimal reproducibable example:

eventpublisher.ads

private with System;

package eventPublisher is

  type Observer_t is limited interface;
  procedure Event (this : in out Observer_t) is abstract;

  type EventPublisher_t is tagged limited private;
  procedure pSubscribeEvent (this : in out EventPublisher_t;
                             TrainId : Natural;
                             sub : Observer_t'Class);

  procedure pUnsubscribeEvent (this : in out EventPublisher_t;
                               TrainId : Natural;
                               sub : Observer_t'Class);

  procedure pNotifyEvent (this : in out EventPublisher_t);

  function fGetEventPublisher return not null access EventPublisher_t;

private

  type EventObserver_t is tagged
     record
       obs : System.Address := System.Null_Address;
     end record;

  type EventPublisher_t is tagged limited
     record
       eventManager : EventObserver_t;
     end record;

end eventPublisher;

eventpublisher.adb

with System.Address_To_Access_Conversions;
with Ada.Text_IO;

package body eventPublisher is

  function "=" (Left, Righ : System.Address) return Boolean renames System."=";

  eventPublisher : access EventPublisher_t := new EventPublisher_t;

  package Event_OPS is new System.Address_To_Access_Conversions (Observer_t'Class);

  function fGetEventPublisher return not null access EventPublisher_t is
  begin
    return eventPublisher;
  end fGetEventPublisher;

  -------------------
  -- pSubscribeEvent --
  -------------------

  procedure pSubscribeEvent
    (this : in out EventPublisher_t; TrainId : Natural;
     sub  :        Observer_t'Class)
  is
  begin
    Ada.Text_IO.Put_Line("Subscribing to Event");
    this.eventManager.obs := sub'Address;
  end pSubscribeEvent;

  procedure pUnsubscribeEvent (this : in out EventPublisher_t;
                               TrainId : Natural;
                               sub : Observer_t'Class) is
  begin
    Ada.Text_IO.Put_Line("Unsubscribing to Event");
    if this.eventManager.obs = sub'Address then
      this.eventManager.obs := System.Null_Address;
    else
      null;
    end if;

  end pUnsubscribeEvent;

  procedure pNotifyEvent (this : in out EventPublisher_t) is
  begin
    if this.eventManager.obs /= System.Null_Address then
      Ada.Text_IO.Put_Line("Notifying to observer");
      Event_OPS.To_Pointer(this.eventManager.obs).Event;
    end if;
  end pNotifyEvent;

components.ads

with eventPublisher;
private with Ada.Finalization;

package components is

  type Root_t (Id : Natural) is abstract tagged limited null record;

  type Child_t (Id : Natural) is limited new Root_t with private;

  procedure pSubscribe (this : in out Child_t);
  procedure pUnsubscribe (this : in out Child_t);

private

  type Component_t (Id : Natural) is limited new
    Ada.Finalization.Limited_Controlled and --> if you comment out this, everything works
    eventPublisher.Observer_t with null record;

  overriding
  procedure Event (this : in out Component_t);

  type Child_t (Id : Natural) is limited new Root_t (Id => Id) with
     record
       component : Component_t(Id => Id);
     end record;

end components;

components.adb

with Ada.Text_IO;

package body components is
  -----------
  -- Event --
  -----------

  overriding procedure Event (this : in out Component_t) is
  begin
    Ada.Text_IO.Put_Line("Processing Event");
  end Event;
  ----------------
  -- pSubscribe --
  ----------------

  procedure pSubscribe (this : in out Child_t) is
  begin
    eventPublisher.fGetEventPublisher.pSubscribeEvent(TrainId => this.Id,
                                                    sub => this.component);
  end pSubscribe;

  procedure pUnsubscribe (this : in out Child_t) is
  begin
    eventPublisher.fGetEventPublisher.pUnsubscribeEvent(TrainId => this.Id,
                                                      sub => this.component);
  end pUnsubscribe;

end components;

And finally, main.adb

with Ada.Text_IO;
with components;
with eventPublisher;

procedure Main is

  c : components.Child_t(Id => 1);
  pub : constant access eventPublisher.EventPublisher_t := eventPublisher.fGetEventPublisher;

begin
  c.pSubscribe;
  pub.pNotifyEvent;
  c.pUnsubscribe;
end Main;

This is the backtrace:

#0  <__gnat_debug_raise_exception> (e=0x45ab60 <program_error>, message=...) at s-excdeb.adb:41
#1  0x0000000000407265 in ada.exceptions.complete_occurrence (x=x@entry=0x467300) at a-except.adb:1019
#2  0x0000000000407275 in ada.exceptions.complete_and_propagate_occurrence (x=x@entry=0x467300) at a-except.adb:1030
#3  0x00000000004076ac in ada.exceptions.raise_with_location_and_msg (e=0x45ab60 <program_error>, f=(system.address) 0x4437d8, l=42, c=c@entry=0, m=m@entry=(system.address) 0x441150) at a-except.adb:1241
#4  0x0000000000407629 in <__gnat_raise_program_error_msg> (file=<optimized out>, line=<optimized out>, msg=msg@entry=0x441150 <ada.exceptions.rmsg_22>) at a-except.adb:1197
#5  0x00000000004078e0 in <__gnat_rcheck_PE_Explicit_Raise> (file=<optimized out>, line=<optimized out>) at a-except.adb:1435
#6  0x0000000000416ba5 in system.finalization_root.adjust ()
#7  0x0000000000404fea in eventpublisher.pnotifyevent ()
#8  0x00000000004041be in main ()

Do you know what the heck is going on? Why the run-time is calling to Adjust for a Limited_Controlled type at trace #6?

I have the following problem and I don't really understand why:

procedure Main is
  
  type Component_t (Id : Natural) is tagged limited null record;
  
  type Root_t (Id : Natural) is tagged limited null record;
  
  type Child_t is limited new Root_t with
     record
       component : Component_t(Id => Id);
     end record;

begin
   --  Insert code here.
   null;
end Main;

9:38 -> error: Id is not visible

error: non-visible declaration at line 5

error: inherited discriminant not allowed here (RM 3.8 (12), 3.8.1 (6))

I'm not sure if the mentioned RM's are the following:

3.8 12/3 A name that denotes a noninherited discriminant is allowed within the declaration of the type, but not within the discriminant_part. If the discriminant is used to define the constraint of a component, the bounds of an entry family, or the constraint of the parent subtype in a derived_type_definition, then its name shall appear alone as a direct_name (not as part of a larger expression or expanded name). A discriminant shall not be used to define the constraint of a scalar component.

3.8.1 6 The discriminant_direct_name shall resolve to denote a discriminant (called the discriminant of the variant_part) specified in the known_discriminant_part of the full_type_declaration that contains the variant_part. The expected type for each discrete_choice in a variant is the type of the discriminant of the variant_part.

If I declare child_t as follows it compiles, but it seems really weird to me. Is it ok and acceptable? Are there any less verbose options to solve it?

type Child_t (Id : Natural) is limited new Root_t (Id => Id) with
   record
     component : Component_t(Id => Id);
   end record;

I have read the following from wikibooks:

A pool access type handles accesses to objects which were created on some specific heap (or storage pool as it is called in Ada). A pointer of these types cannot point to a stack or library level (static) object or an object in a different storage pool. Therefore, conversion between pool access types is illegal. (Unchecked_Conversion may be used, but note that deallocation via an access object with a storage pool different from the one it was allocated with is erroneous.)

According the bold text, if the named access types belongs to the same memory pool then the conversion is legal?

I'm implementing a composite pattern, and I think I could improve the design if the composites return references to its concrete leaves and composites, avoiding the use of keyword "all" in the named access definition. I think I need memory pools to accomplish with it, but I think that it is an advanced feature and I haven't found enough documentation to be sure I can implement one by myself correctly.

I have been following the links shared in this post. Does anybody know other resources after ten years?