❌ About FreshRSS

Normal view

There are new articles available, click to refresh the page.
Before yesterdayNews from the Ada programming language world

Ada design by contracts critical software

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?

Ada interfacing C++: instance destroyed

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!

Linking erros xerces-c on GNAT

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?

Ada2012: possible error for Ada.Finalization.Limited_Controlled?

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?

Ada2012: inherited discriminant not allowed here

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;

Ada2012 controlled types error: call to abstract procedure must be dispatching

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.

Ada2012: Assertion_Policy

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?

Ada: named access types and memory pools

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?

Ada and C++ interface, avoid duplicated code [closed]

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?

Ada visitor design pattern and generics

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;
  1. 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;
  1. 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;
  1. 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;
  1. 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.

Ada: polymorphic callbacks

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;

Ada.Containers.Formal_Indefinite_Vectors memory leak

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?

Ada2012 & GNAT: compile library under a namespace

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.

Parametrizing blob types using gnatcoll.sql

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?

Maximum line length Ada.Text_IO.Put_Line

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.

❌
❌