I'm working on a C++ application, Module_A, that has to use a diverse module, Module_B_Ada and Module_B_CPP depending on configuration.

Module_A + Module_B_Language will be compiled in different OS. I want to avoid duplicating Module_A to have a Module_A for Ada compilation and a Module_A for C++ compilation.

For now, the only thing that came to my mind has been to separate the code that uses the Ada module and exclude it from compilation when is compiled for C++ to avoid linking errors for unresolved symbols.

Another thing I'm thinking about is to comment the "extern" statement on the Module_A and define the Ada services to a void implementation when compiling for C++.

Have yoy ever faced a similar problem? How have you solved it?

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?

According Ada2012 RM Assertion_Policy:

10.2/3 A pragma Assertion_Policy applies to the named assertion aspects in a specific region, and applies to all assertion expressions specified in that region. A pragma Assertion_Policy given in a declarative_part or immediately within a package_specification applies from the place of the pragma to the end of the innermost enclosing declarative region. The region for a pragma Assertion_Policy given as a configuration pragma is the declarative region for the entire compilation unit (or units) to which it applies.

This means that if I have a package hierarchy as per the following example:

└───Root
    ├───Child1
    ├───Child2
    │   └───GrandSon
    └───Child3

And if I define the pragma Assertion_Policy at Root package specification, it will affect to the whole package hierarchy right?

I'm facing a compilation error where I'm not sure about what is going on.

I provide a minimal reproducibable example; if I implement the Initialize procedure, everything is ok and no errors are thrown. The same occurs if class Derived_t has no Hashed_Maps instantiation component, which it's full view is a controlled type and I don't know if it could be related.

with Ada.Finalization;
private with Ada.Containers.Hashed_Maps;
private with Ada.Unchecked_Deallocation;

package root is
  
  type Root_t is limited interface;
  
  type Derived_t is abstract limited new Ada.Finalization.Limited_Controlled and
    Root_t with private;
  
  overriding
  procedure Initialize (this : in out Derived_t) is abstract; --if null implementation is provided, no error is raised
  
  overriding
  procedure Finalize (this : in out Derived_t);
  
private
  
  type array_t is array (Positive range <>) of Positive;
  type arrayPtr_t is access array_t;
  
  function fHash (key : Positive) return Ada.Containers.Hash_Type is
    (Ada.Containers.Hash_Type(key));
  
  package HashedDict_pck is new Ada.Containers.Hashed_Maps
    (Key_Type => Positive,
     Element_Type => Positive,
     Hash => fHash,
     Equivalent_Keys => "=");
  
  --The compilation error is raised before name Derived_t
  type Derived_t is abstract limited new Ada.Finalization.Limited_Controlled and
    Root_t with
     record
       arrayMember : arrayPtr_t;
       dict : HashedDict_pck.map;
     end record;
  
  procedure pFreeArray is new Ada.Unchecked_Deallocation
    (array_t, arrayPtr_t);

end root;

package body root is

  --------------
  -- Finalize --
  --------------

  overriding procedure Finalize (this : in out Derived_t) is
  begin
    this.dict.Clear;
    pFreeArray(this.arrayMember);
  end Finalize;

end root;

The compilation error occurs at line 33 column 8, just before entity name Derived_t in the private part: call to abstract procedure must be dispatching.

I know that controlled types are usually implemented privately, to hide the procedures to clients; I decided to make it public to enforce implementers of concrete classes to implement the Initialize procedure.

An implementer would do the following to implement a concrete class:

package root.concrete is

  type Concrete_t is new Derived_t with private;

  overriding
  procedure Initialize(this : in out Concrete_t); --Implementation will initialize Derived_t arrayMember

  --other Concrete_t public primitives

private

  type Concrete_t is new Derived_t with 
    record
      --Some stuff
    end record;

end root.concrete;

I think that, as I declare the map as a member record, and as the map is a controlled type, it needs to initialise its enclosing record but, as the Initialize is abstract, the compiler don't know what to call. Am I right?

I'll privatize the use of controlled types with a null default implementation of the Initialize to fix it, anyway an implementer shall implement the procedure for a concrete class to construct it correctly.

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'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 to use a C++ library that uses xerces-c. Then I have an Ada project that imports two symbols from the previously mentioned C++ library. When I try to build the main of the Ada project, a bunch of undefined references arises, so I suppose I'm not linking correctly to xerces-c. I've ensured y have the libxerces-c.a and the headers in my path (I'm using CentOS).

This is the package Linker I'm using in my gpr, which I found by googling post of people having similar link errors:

package Linker is
  for Linker_Options use ("-Wl", "-Bstatic", "-lxerces-c", "-Wl", "-Bdynamic");
end Linker;

This is an example of one of the linking erros: undefined reference to `xercesc_3_2::XMLPlatformUtils::Initialize(char const*, char const*, xercesc_3_2::PanicHandler*, xercesc_3_2::MemoryManager*)'

I'm solving the problems for now by creating a gpr library project for xerces-c with for Externally_Built use "True"; and placing the libxerces-c.a manually in the lib directory of that project, but it really sounds weird to me. This way the linking erros disappear and everything seems to work.

Has anybody faced similar problems?

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 have a question related to applying contracts in a critical environment.

Imagine I have the following function to divide:

function div (dividend, divisor : Float) return Float
with Pre => divisor /= 0;

Well, for me the pre-condition is part of the signature of the function and every client must be aware of the contract, if a client pass a zero to the divisor argument is its fault bacause he is violating the contract and thus the function will fail. In testing, with pre-conditions activated, the code will fail showing a contract violation and, in production with pre-conditions deactivated, would fail raising a constraint.

As a constraint error is not acceptable in a critical environment, this is what the client is requiring me for the implementation, to call a module that manages inconsistencies:

function div (dividend, divisor : Float) return Float is
begin
  if divisor = 0 then
    InconsistencyManager.inconsistency ("Some Log"); --It firstly logs a message and then does an infinite loop
  end;

  return dividend / divisor; --If everything is ok, return the division
end div;

For me this side effect for a function its quite weird, and for me violating a contract is like passing the wrong type to a subprogram, the difference is that this kind of error is caught at compilation time and the contract violation, if there aren't enough tests, could stop the execution of the program when is already installed.

Do you really has to protect against human stupidity like this? Do you really has to penalize the function execution making always that question?