When I used this method a few years ago, with Ada from the Ubuntu repository, it worked fine. Now, with my installation from Adacore, not so anymore.

The method consists of 2 commands (time.h as example)

1. g++ -c -fdump-ada-spec -C /usr/include/time.h
2. gcc -c -gnat05 *.ads

While the first command executes without any problem, the second one returns:

gcc: fatal error: cannot execute ‘gnat1’: execvp: No such file or directory

It doesn't depend on the -gnat05 option. There is indeed no gnat1 in the bin directory of the Ada installation. Mine is version 2021. I am reluctant to install the GNU version in parallel, I might mix up things.

Any other idea?

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!

There seem to be two different ways to do the same thing when using the AUnit library:

Using the AUnit.Test_Cases.Test_Case type, creating some function tests, then register each tests with the AUnit.Test_Cases.Register_Tests function. We can then add this Test_Case to a Suite using the function AUnit.Test_Suites.Add_Test.

There some example of this:

• the example of the cookbook
• this SO answer
• in the unit test of AdaYaml

(Surprisingly, there no examples using this way in the AUnit repository.)

The other way is to use the AUnit.Test_Fixtures.Test_Fixture type, creating some function tests. These tests can then be added to a Suite using the generic package AUnit.Test_Caller with the functions AUnit.Test_Suites.Add_Test and AUnit.Test_Caller.Create.

I can see way of using Test_Caller in:

• the example of the cookbook
• the examples AUint repo
• in the unit test of json-ada

The only difference I can see is that, when using the AUnit.Test_Cases.Test_Case, you can override the Set_Up_Case, Set_Up, Tear_Down and Tear_Down_Case functions. While with the AUnit.Test_Fixtures.Test_Fixture you can only override the Set_Up and Tear_Down functions (because the tests are not group under a Test_Case).

Appart from that, I don't really see much difference.

So, what is the use of the AUnit.Test_Fixtures.Test_Fixture type with the generic package AUnit.Test_Caller ? Why would use this over the (simpler ?) AUnit.Test_Cases.Test_Case type ?

Every example I have seen in one format can be transformed into the other (the Set_Up_Case and Tear_Down_Case set appart). Could give an example which use one but cannot be done by the other ?

I want to integrate my Ada static library (libnewapi.a) with my C source code (main.c). I do not have any issues generating the static library but when trying to link it with main.c. I get the below link error, libnewapi.a(unit1.o):unit1.adb:(.text+0x31): undefined reference to `__gnat_rcheck_CE_Overflow_Check' I am not using this reference in my main.c not in any of my Ada files. I do not know why this reference was added automatically. It is crucial that I need to link my main.c using a static Ada library for my project. I do not know where I am going wrong. Help is much appreciated. Thanks!

I am generating libnewapi.a using a GPR as below,

    -- ada_gen_a.gpr
    project ada_gen_a is
       for Languages use ("Ada");
       for Source_Dirs use ("./");
       for Library_Name use "newapi";
       for Library_Dir use "./Lib/";
       for Library_Kind use "static";

       package Naming is
          for Spec_Suffix ("ada") use ".ads";
          for Body_Suffix ("ada") use ".adb";
          for Separate_Suffix use ".adb";
          for Dot_Replacement use ".";
          for Casing use "mixedcase";
       end Naming;

       Ada_Switches := ("-gnato", "-O2");

       package Compiler is
          for Default_Switches ("ada") use Ada_Switches;
       end Compiler;

       package Binder is
          for Default_Switches ("Ada") use ("-n","-Lada");
       end Binder;
    end ada_gen_a;

Ada Sourcefiles:

    --  unit1.ads
    package Unit1 is
       function Add (A, B : Integer) return Integer;
       pragma Export (C, Add, "ada_add");
    end Unit1;

    -- unit1.adb
    package body Unit1 is
       function Add (A, B : Integer) return Integer is
       begin
          return A + B;
       end Add;
    end Unit1;

C Source File:

    /* main.c */
    #include <stdio.h>
    extern void ada_add (void);
    int main (int argc, char *argv[])
    {
       int a = 21, b = 7, c = 0;
       printf ("%d", a);
       printf ("%d", b);
       c = ada_add(a,b);
       printf ("%d", c);
       return 0;
    }

I am using the below GPR to link the above main.c with the Ada static library generated using ada_gen_a.gpr.

    -- Ada_Use_A.gpr
    with "newapi.gpr";
    project Ada_Use_A is

       for Languages use ("C");
       for Source_Dirs use (".");
       for Source_Files use ("main.c");

       package Naming is
          for Casing use "mixedcase";
       end Naming;

       Ada_Switches := ("-gnato", "-O2");

       package Compiler is
          for Default_Switches ("C") use ("-O2", "-Wall");
          for Default_Switches ("Ada") use Ada_Switches;
       end Compiler;

       package Binder is
          for Default_Switches ("Ada") use ("-n","-Lada");
       end Binder;

       for Main use ("main.c");

    end Ada_Use_A;

    -- newapi.gpr
    project newapi is
       for Externally_Built use "true";
       for Source_Files use ();
       for Library_Dir use ".\lib\";
       for Library_Name use "newapi";
       for Library_Kind use "static";
    end newapi;

When I try to build the Ada_Use_A.gpr GPS I get the below linker error, libnewapi.a(unit1.o):unit1.adb:(.text+0x31): undefined reference to __gnat_rcheck_CE_Overflow_Check' gprbuild: link of main.c failed`

I'm trying to create a static library from Ada code that can be linked with some C code without using GNAT tools for the final linking. My use case is that I'm trying to deliver a library written in Ada towards a codebase in C that will be built for an embedded target. The toolchain to build the final binary for the target does not contain GNAT tools and hence the requirement to be able to link the library without GNAT.

When I try to link the library, I get a lot of errors about undefined references.

Here is a minimal code example. C_Ada_Cross.gpr file:

project C_Ada_cross is
   for Library_Name use "MathFunc";
   for Source_Dirs use ("src", ".");
   for Object_Dir use "obj";
   for Library_Kind use "static";
   for Library_Interface use ("MathFunc_Ada");
   for Library_Src_Dir use "include";
   for Library_Dir use "lib";
end C_Ada_cross;

MathFunc_Ada.ads file:

with Interfaces.C; use Interfaces.C;

function MathFunc_Ada(a: C_Float; b: C_Float) return C_Float
    with 
        Export      => True,
        Convention  => C,
        External_Name => "MathFunc_Ada";

MathFunc_Ada.adb file:

with Ada.Numerics.Elementary_Functions; 
function MathFunc_Ada(a: C_Float; b: C_Float) return C_Float is
    use Ada.Numerics.Elementary_Functions;
begin
    return C_Float(sin(Float(a)) + cos(Float(b)));
end MathFunc_Ada;

main.c file:

#include <stdio.h>

extern float MathFunc_Ada(float a, float b);
extern void MathFuncinit();
extern void MathFuncfinal();

void main() {
  MathFuncinit();

  float a = 10.2;
  float b = 20.6;
  float c = MathFunc_Ada(a, b);
  
  printf("%f\n", c);
  MathFuncfinal();
}

To build, I did the following:

gprbuild -P C_Ada_cross.gpr # libMathFunc.a 
gcc main.c -L./lib -lMathFunc

And this generates loads of errors like so:

/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libMathFunc.a(p__MathFunc_0.o):MathFunc_Ada.a:(.text+0x20): undefined reference to `ada__numerics__elementary_functions__sin'
./lib/libMathFunc.a(p__MathFunc_0.o):MathFunc_Ada.a:(.text+0x20): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `ada__numerics__elementary_functions__sin'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libMathFunc.a(p__MathFunc_0.o):MathFunc_Ada.a:(.text+0x2f): undefined reference to `ada__numerics__elementary_functions__cos'
./lib/libMathFunc.a(p__MathFunc_0.o):MathFunc_Ada.a:(.text+0x2f): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `ada__numerics__elementary_functions__cos'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libMathFunc.a(p__MathFunc_0.o):b__mathfunc.ad:(.text+0x118): undefined reference to `system__secondary_stack__ss_stackIP'
./lib/libMathFunc.a(p__MathFunc_0.o):b__mathfunc.ad:(.text+0x118): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `system__secondary_stack__ss_stackIP'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libMathFunc.a(p__MathFunc_0.o):b__mathfunc.ad:(.text+0x14e): undefined reference to `__gnat_runtime_finalize'
./lib/libMathFunc.a(p__MathFunc_0.o):b__mathfunc.ad:(.text+0x14e): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `__gnat_runtime_finalize'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libMathFunc.a(p__MathFunc_0.o):b__mathfunc.ad:(.text+0x265): undefined reference to `__gnat_runtime_initialize'
./lib/libMathFunc.a(p__MathFunc_0.o):b__mathfunc.ad:(.text+0x265): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `__gnat_runtime_initialize'

and more...

I also tried:

gcc main.c -L./lib -lMathFunc -lgnat -lgnarl -ldl

and that gives different undefined reference errors:

/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: /usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: DWARF error: can't find .debug_ranges section.
./lib/libgnat.a(adaint.o):adaint.c:(.text+0x38): undefined reference to `__imp__wsplitpath'
./lib/libgnat.a(adaint.o):adaint.c:(.text+0x38): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `__imp__wsplitpath'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libgnat.a(adaint.o):adaint.c:(.text+0x480): undefined reference to `__mingw_vsprintf'
./lib/libgnat.a(adaint.o):adaint.c:(.text+0x480): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `__mingw_vsprintf'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libgnat.a(adaint.o):adaint.c:(.text+0x4d5): undefined reference to `__imp__time64'
./lib/libgnat.a(adaint.o):adaint.c:(.text+0x4d5): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `__imp__time64'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libgnat.a(adaint.o):adaint.c:(.text+0x4ec): undefined reference to `__imp__time64'
./lib/libgnat.a(adaint.o):adaint.c:(.text+0x4ec): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `__imp__time64'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libgnat.a(adaint.o):adaint.c:(.text+0x4fc): undefined reference to `__imp__localtime64'
./lib/libgnat.a(adaint.o):adaint.c:(.text+0x4fc): relocation truncated to fit: R_X86_64_PC32 against undefined symbol `__imp__localtime64'
/usr/lib/gcc/x86_64-pc-cygwin/9.3.0/../../../../x86_64-pc-cygwin/bin/ld: ./lib/libgnat.a(adaint.o):adaint.c:(.text+0x54f): undefined reference to `__imp__gmtime64'

and more...

The last approach is very similar to the one presented here: https://stackoverflow.com/a/70036096/3979564, but that didn't work for me. In fact, I even tried the exact same code and commands presented there, but that gave me similar errors.

I found this option when searching for solutions: http://www.white-elephant.ch/articles/AUJ%2042-3.pdf, but that seems very convoluted to make a copy of and rewrite original Ada source files.

Given Ada's focus on embedded applications where static linking is the only option in many cases, I feel like there must be a simpler way to build static libraries.

Am I missing something? Is there an easier way to build static libraries in Ada?

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'm taking my first steps in Ada and attempting to write a package which manipulates the CPUID instruction. I found some sequences on the OSDev wiki here for checking the EFLAGS.ID bit that I'm attempting to modify into an Ada function using inline assembler, but I'm running into a persistent segfault when trying to run it. First, the package spec & body:

-- Specification file: Cpuid.ads --

with Standard_Types; use Standard_Types;

package Cpuid is
    
    function Is_Supported return Boolean;

end Cpuid;

-- Body file: Cpuid.adb --

with System.Machine_Code; use System.Machine_Code;

package body Cpuid is

    function Is_Supported return Boolean is
        HT  : constant Character := Character'Val(16#09#);
        LF  : constant Character := Character'Val(16#0A#);
        EAX : Unsigned_32 := 16#0000_0000#;
    begin
        Asm ("pushfq"                    & LF & HT &
             "pushfq"                    & LF & HT &
             "popq    %%rax"             & LF & HT &
             "xorq    0x00200000, %%rax" & LF & HT &
             "pushq   %%rax"             & LF & HT &
             "popfq"                     & LF & HT &
             "pushfq"                    & LF & HT &
             "popq    %%rax"             & LF & HT &
             "xorq    (%%rsp), %%rax"    & LF & HT &
             "popfq"                     & LF & HT &
             "andq    0x00200000, %%rax" & LF & HT &
             "movl    %%eax, %0",
             Outputs  => Unsigned_32'Asm_Output ("=g", EAX),
             Volatile => True);
        if EAX /= 16#0000_0000# then 
            return True; 
        else 
            return False; 
        end if;
    end Is_Supported;

end Cpuid;

The Cpuid.Is_Supported function is called by a main program which looks like this:

with Ada.Text_IO;    use Ada.Text_IO;
with Standard_Types; use Standard_Types;
with Cpuid;

procedure Cpuid_Check is
    Some_Int : Unsigned_32 := 0;
begin
    if Cpuid.Is_Supported then
        Put_Line ("CPUID instruction supported on this CPU.");
    else
        Put_Line ("CPUID instruction not supported.");
    end if;
end Cpuid_Check;

Note that the Standard_Types import is just a spec-only package consisting of handwritten type definitions for Unsigned_8, Unsigned_16, and Unsigned_32.

When I attempt to run this program, the program fails with PROGRAM_ERROR : EXCEPTION_ACCESS_VIOLATION. Using GDB allows me to trace the error to a SIGSEGV, but I am not able to trace the violation further to a particular instruction issuance. The full debugger output is as follows:

Temporary breakpoint 14, 0x00000000004016e0 in cpuid_check ()
[program stopped: breakpoint-hit]
(gdb) -exec-next
Single stepping until exit from function _ada_cpuid_check,
which has no line number information.
[program running]

Program received signal SIGSEGV, Segmentation fault.
0x0000000000401ede in cpuid.is_supported ()
[program stopped: signal-received]
(gdb) -exec-next
Single stepping until exit from function cpuid__is_supported,
which has no line number information.
[program running]

Program received signal SIGSEGV, Segmentation fault.
0x00007ffc4d3473f9 in KERNEL32!IsBadReadPtr () from C:\Windows\System32\kernel32.dll
[program stopped: signal-received]
(gdb) 

I've checked to ensure that I'm leaving the stack "as I found it", which, to the best of my ability, appears to be the case - the same number of pushes and pops occur within the inline assembly section. I've also rearranged the assembly sequence into src, dest format, as my reading on GAS indicates that is the syntax used. In the process, however, I bamboozled myself - I'm more used to Intel/NASM syntax, and GAS looks like a mess in comparison.

Is there a way to rectify this function so that it functions properly?

EDIT: Here is the disassembly dump from GDB, as noted in the comments:

(gdb) disas
Dump of assembler code for function cpuid__is_supported:
   0x0000000000401ec4 <+0>: push   %rbp
   0x0000000000401ec5 <+1>: mov    %rsp,%rbp
   0x0000000000401ec8 <+4>: sub    $0x10,%rsp
   0x0000000000401ecc <+8>: movb   $0x9,-0x1(%rbp)
   0x0000000000401ed0 <+12>:    movb   $0xa,-0x2(%rbp)
   0x0000000000401ed4 <+16>:    movl   $0x0,-0x8(%rbp)
   0x0000000000401edb <+23>:    pushfq 
   0x0000000000401edc <+24>:    pushfq 
   0x0000000000401edd <+25>:    pop    %rax
=> 0x0000000000401ede <+26>:    xor    0x200000,%rax
   0x0000000000401ee6 <+34>:    push   %rax
   0x0000000000401ee7 <+35>:    popfq  
   0x0000000000401ee8 <+36>:    pushfq 
   0x0000000000401ee9 <+37>:    pop    %rax
   0x0000000000401eea <+38>:    xor    (%rsp),%rax
   0x0000000000401eee <+42>:    popfq  
   0x0000000000401eef <+43>:    and    0x200000,%rax
   0x0000000000401ef7 <+51>:    mov    %eax,%eax
   0x0000000000401ef9 <+53>:    mov    %eax,-0x8(%rbp)
   0x0000000000401efc <+56>:    cmpl   $0x0,-0x8(%rbp)
   0x0000000000401f00 <+60>:    je     0x401f09 <cpuid__is_supported+69>
   0x0000000000401f02 <+62>:    mov    $0x1,%eax
   0x0000000000401f07 <+67>:    jmp    0x401f0e <cpuid__is_supported+74>
   0x0000000000401f09 <+69>:    mov    $0x0,%eax
   0x0000000000401f0e <+74>:    nop
   0x0000000000401f0f <+75>:    nop
   0x0000000000401f10 <+76>:    add    $0x10,%rsp
   0x0000000000401f14 <+80>:    pop    %rbp
   0x0000000000401f15 <+81>:    retq   
   0x0000000000401f16 <+82>:    nop
   0x0000000000401f17 <+83>:    nop
   0x0000000000401f18 <+84>:    nop
   0x0000000000401f19 <+85>:    nop
   0x0000000000401f1a <+86>:    nop
   0x0000000000401f1b <+87>:    nop
   0x0000000000401f1c <+88>:    nop
   0x0000000000401f1d <+89>:    nop
   0x0000000000401f1e <+90>:    nop
   0x0000000000401f1f <+91>:    nop
End of assembler dump.

I have a limited interface defined in my_interface_package.ads.

package My_Interface_Package is

   type My_Interface is limited interface;

   procedure Procedure_1 (Some_Parameter : in out My_Interface) is null;
   procedure Procedure_2 (Some_Parameter_1 : in out My_Interface; Some_Parameter_2 : in String) is abstract;

end My_Interface_Package;

The type My_Class implements this interface (in my_class_package.ads and my_class_package.adb).

with My_Interface_Package;

package My_Class_Package is

   type My_Class is limited new My_Interface_Package.My_Interface with record
      Some_Element : Boolean;
   end record;

   overriding procedure Procedure_1 (Some_Parameter : in out My_Class);
   overriding procedure Procedure_2 (Some_Parameter_1 : in out My_Class; Some_Parameter_2 : in String);

end My_Class_Package;

with Ada.Text_IO;

package body My_Class_Package is

   procedure Procedure_1 (Some_Parameter : in out My_Class) is
   begin
      Ada.Text_IO.Put_Line("Inside Procedure_1.");
   end;

   procedure Procedure_2 (Some_Parameter_1 : in out My_Class; Some_Parameter_2 : in String) is
   begin
      Ada.Text_IO.Put_Line("Inside Procedure_2.");
   end;

end My_Class_Package;

I have a generic package My_Generic_Package defined in my_generic_package.ads and my_generic_package.adb. It expects a type My_Generic_Type. I want this type to accept any concrete implementation of the interface My_Interface.

with My_Interface_Package;

generic
   type My_Generic_Type is limited new My_Interface_Package.My_Interface with private; -- The problem seems to be in this declaration.
package My_Generic_Package is

   type My_Generic_Class is record
      Element : My_Generic_Type;
   end record;

   procedure Calling_Procedure_1 (Some_Parameter : in out My_Generic_Class);
   procedure Calling_Procedure_2 (Some_Parameter_1 : in out My_Generic_Class; Some_Parameter_2 : in String);

end My_Generic_Package;

with Ada.Text_IO;

package body My_Generic_Package is

   procedure Calling_Procedure_1 (Some_Parameter : in out My_Generic_Class) is
   begin
      Ada.Text_IO.Put_Line("Calling Procedure_1.");
      Procedure_1(Some_Parameter);
   end;

   procedure Calling_Procedure_2 (Some_Parameter_1 : in out My_Generic_Class; Some_Parameter_2 : in String) is
   begin
      Ada.Text_IO.Put_Line("Calling Procedure_2.");
      Procedure_2(Some_Parameter_1, Some_Parameter_2);
   end;

end My_Generic_Package;

My main.adb:

with Ada.Text_IO;
with My_Class_Package;
with My_Generic_Package;

procedure Main is
   package My_Instanciated_Package is new My_Generic_Package(My_Generic_Type => My_Class_Package.My_Class);
   My_Object : My_Instanciated_Package.My_Generic_Class;
begin
   My_Instanciated_Package.Calling_Procedure_1(My_Object);
   My_Instanciated_Package.Calling_Procedure_2(My_Object, "some_string");
   Ada.Text_IO.Put_Line("Program terminated.");
end Main;

GNAT 12.2.0 tells me my_generic_package.ads:3:73: missing ";" (he doesn't want the 'with private' part, but even without it, also fail).

I have tried a bunch of other declaration but ultimatly (trying to inspire myself from wikibooks), all failed. Any idea of what's wrong ?

I'm using SDL to retrieve the address of the function. That much seems to be working, since I'm using the same subprogram that's working for all my other function calls.

Here are all the relevant code snippits in the spec:

type GLenum is new Uint32;

subtype glTexImage2D_Target is GLenum with Static_Predicate => glTexImage2D_Target in GL_TEXTURE_2D | GL_TEXTURE_RECTANGLE | GL_PROXY_TEXTURE_RECTANGLE;
subtype glTexImage2D_Dtype is GLenum with Static_Predicate => glTexImage2D_Dtype in GL_BYTE | GL_UNSIGNED_BYTE;
subtype glTexImage2D_InternalFormat is GLenum with Static_Predicate => glTexImage2D_InternalFormat in GL_DEPTH_COMPONENT | GL_DEPTH_STENCIL | GL_RED | GL_RG | GL_RGB | GL_RGBA;
subtype glTexImage2D_Format is GLenum with Static_Predicate => glTexImage2D_Format in GL_RED | GL_RG | GL_RGB | GL_BGR | GL_RGBA | GL_BGRA | GL_RED_INTEGER | GL_RG_INTEGER | GL_RGB_INTEGER | GL_BGR_INTEGER | GL_RGBA_INTEGER | GL_BGRA_INTEGER | GL_STENCIL_INDEX | GL_DEPTH_COMPONENT | GL_DEPTH_STENCIL;

procedure glTexImage2D(target : glTexImage2D_Target; level : Integer; internalFormat : glTexImage2D_InternalFormat; width : Integer; height : Integer; format : glTexImage2D_Format; dtype : glTexImage2D_Dtype; pixels : System.Address) with Pre => (target /= GL_TEXTURE_RECTANGLE and target /= GL_PROXY_TEXTURE_RECTANGLE) or Level = 0;

procedure Set_OpenGL_Subprogram_Address(Addr : in out System.Address; Name : String);

glTexImage2D_C_Address : System.Address := System.Null_Address;

Could_Not_Load_OpenGL_Subprogram : exception;

And here are the relevant snippits in the body:

procedure glTexImage2D(target : glTexImage2D_Target; level : Integer; internalFormat : glTexImage2D_InternalFormat; width : Integer; height : Integer; format : glTexImage2D_Format; dtype : glTexImage2D_Dtype; pixels : System.Address) is
begin
    Set_OpenGL_Subprogram_Address(glTexImage2D_C_Address, "glTexImage2D");
    declare
        procedure glTexImage2D_C(target : GLenum; level : GLint; internalFormat : GLint; width : GLsizei; height : GLsizei; border : GLint; format : GLenum; dtype : GLenum; data : System.Address)
        with Import, Convention => Stdcall, Address => glTexImage2D_C_Address;
    begin
        glTexImage2D_C(GLenum(target), GLint(level), GLint(internalFormat), GLsizei(width), GLsizei(height), GLint'(0), GLenum(format), GLenum(dtype), pixels);
    end;
end glTexImage2D;

--This seems to work... but here it is just in case.
procedure Set_OpenGL_Subprogram_Address(Addr : in out System.Address; Name : String) is
begin
    if Addr = System.Null_Address then
        Addr := SDL_GL_GetProcAddress(Value(New_String(Name)));
        if Addr = System.Null_Address then
            raise Could_Not_Load_OpenGL_Subprogram with Name;
        end if;
    end if;
end Set_OpenGL_Subprogram_Address;

Finally, the pixels I'm passing in is an address indicating an object of type:

type Uc_Array is array(Integer range <>) of aliased Interfaces.C.unsigned_char;

The stack is being corrupted on the call to glTexImage2D_C. I discovered this by using gdb:

Here you can see the parameters I'm passing as well; target 3553, level 0, internalformat 6408, width 63, height 63, format 6408, dtype 5121, non-zero pixels address. The subprogram address is being set to a non-zero value. But after the call to glTexImage2D_C, the value of $sp (the stack pointer) has increased by 16#24#.

I've tried adjusting the height and width I pass to glTexImage2D_C, both to 10 and both to 1000, just to see if giving it more (or less) buffer prevents stack corruption, but in every case, the stack pointer is different before and after the procedure call.

I'm hoping this is a simple matter of an incorrect datatype or something... Here's the prototype of glTexImage2D on the OpenGL side:

void glTexImage2D(  GLenum target,
    GLint level,
    GLint internalformat,
    GLsizei width,
    GLsizei height,
    GLint border,
    GLenum format,
    GLenum type,
    const void * data);

(As a final note, I do intend to clean up the awkward lazy loading tactic you see above, if I can ever get this to actually work. For now I'm leaving it this way so I can eliminate the chance of trying to call a function that hasn't been loaded yet, while I'm still trying to debug the call itself. The tactic of using a nested procedure declared inside a declare...begin...end block is working for other OpenGL functions.)

Get(TheFile, IntValue); works great with strings formatted like 16#12# to read hex values. Shouldn't Get from a string function the same way?

I tried this, but passing 16#12# only yields 16. Pure hex, eg F8 results in an exception

with Ada.Text_IO;         use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;

procedure hex is
   IntValue  : Integer;
   Last : Positive;
begin
   Put("Enter a hexadecimal string: ");
   Get(HexString);

   -- Convert the hexadecimal string to an integer
   Get(From => HexString, Item => IntValue, Last => Last);

   Put ("The integer value is: ");
   Put (IntValue, Width => 0);
   New_Line;
end hex;

I am trying to get Ada code to compile to a DLL to be callable in C. So far I have managed to get this to work for simple types such as integers but i'm having difficulty with more complex types such as array's or records/structs.

Below is my Ada code for an record/struct. It is a dynamic library which i compile to a dll using the command "gprbuild -P ./math.gpr -p":

person.adb
with Interfaces.C; use Interfaces.C;

package body Person is

   function Set_Age_To_Five(P : Person_Record) return Person_Record is
      Result : Person_Record;
   begin
      Result := P;
      Result.Age := 5;
      return Result;
   end Set_Age_To_Five;

end Person;

person.ads

with Interfaces.C; use Interfaces.C;

package Person is

   type Person_Record is record
      Name    : String(1 .. 100);
      Age     : Interfaces.C.int;
      Address : String(1 .. 100);
   end record with Convention => C_Pass_By_Copy;

   function Set_Age_To_Five(P : Person_Record) return Person_Record;
   pragma Export (C, Set_Age_To_Five, "Set_Age_To_Five");

end Person;

math.gpr

library project Math is
    for Languages use ("Ada");
    for Library_Name use "Person";
    for Source_Dirs use ("src");
    for Object_Dir use "obj";
    for Library_Dir use "lib";
    for Library_Kind use "Dynamic";
end Math;

I then have a C header file math.h:

#ifndef MATH_H
#define MATH_H

#ifdef __cplusplus
extern "C"
#endif

typedef struct {
    char Name[101];
    int Age;
    char Address[101];
} Person_Record;

Person_Record Set_Age_To_Five(Person_Record P);

#ifdef __cplusplus

#endif

#endif /* MATH_H */

and finally my C code:

#include <stdio.h>
#include "math.h"

int main() {
    Person_Record p, q, r;

    // Initialize the person record
    snprintf(p.Name, sizeof(p.Name), "John");
    p.Age = 25;
    snprintf(p.Address, sizeof(p.Address), "123 Main St");

    // Call the Set_Age_To_Five function from the DLL
    q = Set_Age_To_Five(p);

    // Print the modified person record
    printf("Name: %s\n", q.Name);
    printf("Age: %d\n", q.Age);
    printf("Address: %s\n", q.Address);

    return 0;
}

This should when executed return

Name: John
Age: 5
Address: 123 Main St

Instead its returning:

Name: John
Age: 25
Address: 123 Main St

I've tried passing by variable, passing by reference. using convention C and convention pass by c in ada.

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?

Why does not Ada support variable function/procedure argument lists? Is it hard to implement or does it somehow go against "we should keep things secure" philosophy of the language?

Varargs were over there at least as early as C and allow very handy things like printf, the likes of which can also be found in other languages like Java or C#. Another neat example is logging functions where it is usual to pass information from all kinds of data types, not only strings, in separate arguments.

And even if this is considered non-secure technique, Ada could still make it better than at least in C by e.g. throwing an exception if there is some mismatch between format string and the actually passed arguments.

I use Glade with GtkAda.

-I can't retrieve the color data in the associate callback (window1_callbacks.adb).

-The Gtk.Color_Chooser.Get_RGBA procedure needs Gtk_Color_Chooser type. And Gtk_Color_Chooser function returns returns GObjet, so we need to convert data from GObject type to Gtk_Color_Chooser type.

And I don' see any function doing this. Thanks Mark

    -- Glade_8.adb
    
    -- units from Gtk
    with Gtk.Main;
    with Glib.Error;     use Glib.Error;
    with Gtk.Widget;     use Gtk.Widget;
    with Gtk.Builder;    use Gtk.Builder;
    with Gtkada.Builder; use Gtkada.Builder;
    
    -- Ada predefined units
    with Ada.Text_IO;    use Ada.Text_IO;
    with Ada.Exceptions;
    
    -- Application specific units
    with Window1_Callbacks; use Window1_Callbacks;
    
    procedure Glade_8 is
    
      Builder       : Gtkada_Builder;
      Error         : aliased Glib.Error.GError;
      FileName      : constant String := "glade_8";
      GladeFileName : constant String := FileName & ".glade";
      use type Glib.Guint;
         
      begin
        -- Appelé dans toutes les applications GtkAda.
        -- Arguments ligne de commande sont analysés & retournés à l'application.
        Gtk.Main.Init;
    
        -- Etape 1 : créer un Builder 
        --         & lui donner accès à la fenetre maitre du fichier XML.
        Gtk_New (Builder);
        if Add_From_File (Gtk_Builder(Builder), GladeFileName, Error'Access) = 0 then
          Put_Line ("Error : " & Get_Message (Error));
          Error_Free (Error);
          return;
        end if;
        Put_Line (FileName & " : loading of builder OK ");
       
        -- Etape 2 : créer les handlers ("poignées") des events
        --             (de façon à préparer les callback).
        Register_Handler (Builder, "on_color1_color_set",    On_Color1_Color_Set'Access);  --Ajout
        
        -- Etape 3 : Do_Connect connecte tous les handlers enregistrés en une fois.
        Do_Connect (Builder);
      --Put_Line ("Booleen du Switch : " & boolean'Image (On_Switch1_State_Set (Builder)));
    
        -- Etape 4 : Afficher la fenetre avec ses dépendances
        Show_All (Gtk_Widget (Get_Object (GTK_Builder (Builder), "window")));
    
        -- Etape 5 : Lancer la boucle infinie.
        Gtk.Main.Main;
    
        -- Etape 6 : appeler Unref quand l'application se termine
        --             pour libérer la memoire associée au Builder.
        Unref (Builder);
        Put_Line ("Program " & FileName & " is finished !");
    
      exception
        when Error : others =>
          Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (Error));
      end Glade_8;
    
    
    -- Glade_8
    
    with Gtkada.Builder; use Gtkada.Builder;
    
    package Window1_Callbacks is
          
      Procedure On_Color1_Color_Set (Builder : access Gtkada_Builder_Record'Class);  -- Ajout
    
    end Window1_Callbacks;
    
     
    
    -- Glade_8
    
    -- units from Gtk
    with Gtk.Label;          use Gtk.Label;
    with Gtk.Check_Button;   use Gtk.Check_Button;
    with Gtk.Toggle_Button;  use Gtk.Toggle_Button;
    with Gtk.Spin_Button;    use Gtk.Spin_Button;
    with Gtk.Switch;         use Gtk.Switch;
    with Gtk.Combo_Box;      use Gtk.Combo_Box;
    with Gtk.GEntry;         use Gtk.GEntry;
    
    with Gtk.Color_Button;            use Gtk.Color_Button;           --Ajout
    with Gtk.Color_Chooser;           use Gtk.Color_Chooser;          --Ajout
    with Gtk.Color_Chooser_Dialog;    use Gtk.Color_Chooser_Dialog;   --Ajout
    with Gtk.Color_Chooser_Widget;    use Gtk.Color_Chooser_Widget;   --Ajout
    with Gtk.Color_Selection;         use Gtk.Color_Selection;        --Ajout
    with Gtk.Color_Selection_Dialog;  use Gtk.Color_Selection_Dialog; --Ajout
    
    with Gdk.RGBA;                    use Gdk.RGBA;                   --Ajout
    
    with Glib;              use Glib;
    
    with Ada.Text_IO;       use Ada.Text_IO;
    
    
    package body Window1_Callbacks  is
        
      ---------------------------------
      -- On_Color1_Color_Set  -- AJOUT
      ---------------------------------
      procedure On_Color1_Color_Set (Builder : access Gtkada_Builder_Record'Class) is
        pragma Unreferenced (Builder);
        Color : Gdk_RGBA;
        begin
    --      void on_color1_color_set(GtkColorButton *c)   // To translate from C to Ada.
    --           {
    --           GdkRGBA color;
    --           gtk_color_chooser_get_rgba (GTK_COLOR_CHOOSER(c), &color); // Récupérer la couleur
    --           printf("red %f\n", color, red);
    --           printf("green %f\n", color, green);     
    --           printf("blue %f\n", color, blue);    
    --           printf("alpha %f\n", color, alpha);    
    --           }
    
    --  window1_callbacks.adb:189:35: error: "GObject_To_Gtk_Color_Chooser" is undefined
          Gtk.Color_Chooser.Get_RGBA (
                                      To_Gtk_Color_Chooser
                                                          (Gtk_Color_Chooser (Get_Object (Builder, "color1"))),
                                                                                                                Color);
      
    --      put_line ("Red : ",   Float'Image (Color.Red));
    --      put_line ("Green : ", Float'Image (Color.Green));     
    --      put_line ("Blue : ",  Float'Image (Color.Blue));    
    --      put_line ("Alpha : ", Float'Image (Color.Alpha));   
          
        end On_Color1_Color_Set;
    
    end Window1_Callbacks;


    <?xml version="1.0" encoding="UTF-8"?>
    <!-- Generated with glade 3.40.0 -->
    <interface>
      <requires lib="gtk+" version="3.24"/>
      <object class="GtkAdjustment" id="adjustment1">
        <property name="upper">100</property>
        <property name="step-increment">1</property>
        <property name="page-increment">10</property>
      </object>
      <object class="GtkListStore" id="liststore1">
        <columns>
          <!-- column-name Col_1 -->
          <column type="gchararray"/>
        </columns>
        <data>
          <row>
            <col id="0">Ligne-1</col>
          </row>
          <row>
            <col id="0">bbb</col>
          </row>
          <row>
            <col id="0">dddd</col>
          </row>
          <row>
            <col id="0">eeeeeeee</col>
          </row>
          <row>
            <col id="0">ligne-5</col>
          </row>
          <row>
            <col id="0">ligne-6</col>
          </row>
        </data>
      </object>
      <object class="GtkWindow" id="window">
        <property name="name">window</property>
        <property name="width-request">89</property>
        <property name="height-request">3</property>
        <property name="can-focus">False</property>
        <property name="hexpand">True</property>
        <property name="vexpand">True</property>
        <property name="border-width">0</property>
        <property name="window-position">center</property>
        <property name="gravity">center</property>
        <child>
          <object class="GtkFixed" id="fixed1">
            <property name="name">fixed1</property>
            <property name="visible">True</property>
            <property name="can-focus">False</property>
            <child>
              <object class="GtkButton" id="button1">
                <property name="name">button1</property>
                <property name="width-request">100</property>
                <property name="height-request">80</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="receives-default">True</property>
                <property name="tooltip-text" translatable="yes"> Click Me!</property>
                <property name="always-show-image">True</property>
                <signal name="clicked" handler="on_button1_clicked" swapped="no"/>
                <child>
                  <object class="GtkImage" id="harddisk">
                    <property name="visible">True</property>
                    <property name="can-focus">False</property>
                    <property name="stock">gtk-harddisk</property>
                    <property name="icon_size">6</property>
                  </object>
                </child>
              </object>
              <packing>
                <property name="x">36</property>
                <property name="y">40</property>
              </packing>
            </child>
            <child>
              <object class="GtkLabel" id="label1">
                <property name="width-request">200</property>
                <property name="height-request">40</property>
                <property name="visible">True</property>
                <property name="can-focus">False</property>
                <property name="tooltip-text" translatable="yes">I am a label hiding here.</property>
                <property name="label" translatable="yes">label</property>
                <attributes>
                  <attribute name="font-desc" value="Sans Bold Italic 15"/>
                  <attribute name="foreground" value="#efef29292929"/>
                </attributes>
              </object>
              <packing>
                <property name="x">150</property>
                <property name="y">170</property>
              </packing>
            </child>
            <child>
              <object class="GtkLabel" id="label2">
                <property name="width-request">200</property>
                <property name="height-request">40</property>
                <property name="visible">True</property>
                <property name="can-focus">False</property>
                <property name="xpad">0</property>
                <property name="ypad">17</property>
                <property name="label" translatable="yes">label2</property>
                <property name="xalign">0.5</property>
                <property name="yalign">0.5</property>
              </object>
              <packing>
                <property name="x">150</property>
                <property name="y">220</property>
              </packing>
            </child>
            <child>
              <object class="GtkRadioButton" id="radio1">
                <property name="label" translatable="yes">radio button 1</property>
                <property name="width-request">100</property>
                <property name="height-request">22</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="receives-default">False</property>
                <property name="halign">start</property>
                <property name="active">True</property>
                <property name="draw-indicator">True</property>
                <signal name="toggled" handler="on_radio1_toggled" swapped="no"/>
              </object>
              <packing>
                <property name="x">190</property>
                <property name="y">30</property>
              </packing>
            </child>
            <child>
              <object class="GtkRadioButton" id="radio2">
                <property name="label" translatable="yes">radio button 2</property>
                <property name="width-request">100</property>
                <property name="height-request">22</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="receives-default">False</property>
                <property name="active">True</property>
                <property name="draw-indicator">True</property>
                <property name="group">radio1</property>
                <signal name="toggled" handler="on_radio2_toggled" swapped="no"/>
              </object>
              <packing>
                <property name="x">190</property>
                <property name="y">60</property>
              </packing>
            </child>
            <child>
              <object class="GtkRadioButton" id="radio3">
                <property name="label" translatable="yes">radio button3</property>
                <property name="width-request">100</property>
                <property name="height-request">22</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="receives-default">False</property>
                <property name="active">True</property>
                <property name="draw-indicator">True</property>
                <property name="group">radio1</property>
                <signal name="toggled" handler="on_radio3_toggled" swapped="no"/>
              </object>
              <packing>
                <property name="x">190</property>
                <property name="y">90</property>
              </packing>
            </child>
            <child>
              <object class="GtkCheckButton" id="check1">
                <property name="label" translatable="yes">check button1</property>
                <property name="width-request">100</property>
                <property name="height-request">30</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="receives-default">False</property>
                <property name="draw-indicator">True</property>
                <signal name="toggled" handler="on_check1_toggled" swapped="no"/>
              </object>
              <packing>
                <property name="x">190</property>
                <property name="y">120</property>
              </packing>
            </child>
            <child>
              <object class="GtkToggleButton" id="toggle1">
                <property name="label" translatable="yes">toggle button</property>
                <property name="width-request">123</property>
                <property name="height-request">36</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="receives-default">True</property>
                <signal name="toggled" handler="on_toggle1_toggled" swapped="no"/>
              </object>
              <packing>
                <property name="x">25</property>
                <property name="y">174</property>
              </packing>
            </child>
            <child>
              <object class="GtkSpinButton" id="spin1">
                <property name="width-request">118</property>
                <property name="height-request">34</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="max-width-chars">2</property>
                <property name="adjustment">adjustment1</property>
                <property name="wrap">True</property>
                <signal name="value-changed" handler="on_spin1_value_changed" swapped="no"/>
              </object>
              <packing>
                <property name="x">25</property>
                <property name="y">218</property>
              </packing>
            </child>
            <child>
              <object class="GtkSwitch" id="switch1">
                <property name="use-action-appearance">True</property>
                <property name="name">switch</property>
                <property name="width-request">100</property>
                <property name="height-request">35</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="active">True</property>
                <signal name="state-set" handler="on_switch1_state_set" swapped="no"/>
              </object>
              <packing>
                <property name="x">27</property>
                <property name="y">284</property>
              </packing>
            </child>
            <child>
              <object class="GtkComboBox" id="combo1">
                <property name="width-request">176</property>
                <property name="visible">True</property>
                <property name="can-focus">False</property>
                <property name="model">liststore1</property>
                <property name="active">0</property>
                <property name="has-entry">True</property>
                <property name="entry-text-column">0</property>
                <property name="id-column">0</property>
                <property name="active-id">0</property>
                <signal name="changed" handler="on_combo1_changed" swapped="no"/>
                <child internal-child="entry">
                  <object class="GtkEntry" id="entry1">
                    <property name="can-focus">False</property>
                    <signal name="changed" handler="on_gentry1_changed" swapped="no"/>
                  </object>
                </child>
              </object>
              <packing>
                <property name="x">38</property>
                <property name="y">357</property>
              </packing>
            </child>
            <child>
              <object class="GtkColorButton" id="color1">
                <property name="width-request">100</property>
                <property name="height-request">33</property>
                <property name="visible">True</property>
                <property name="can-focus">True</property>
                <property name="receives-default">True</property>
                <signal name="color-set" handler="on_color1_color_set" swapped="no"/>
              </object>
              <packing>
                <property name="x">298</property>
                <property name="y">303</property>
              </packing>
            </child>
          </object>
        </child>

  </object>
</interface>

On arm-none-eabi-gcc (cortex m0 / stm32f03), I see address values from Attribute'Address that seem to differ between those inserted at compile time and those which should be real. As an example, I look at the address of Hardfault_Handler.

This is my code:

 procedure Hardfault_Handler is
      SP : Address         := Get_Stack_Pointer; -- save sp after handler entry
      PC                 : Address := Get_Program_Counter; -- save current pc
      PC_Offset          : Storage_Offset  := PC - Hardfault_Handler'Address;
      Num_Of_Pushed_Regs : Natural         := 0;
      SP_Calc            : Integer_Address := To_Integer (SP);
      package Thumb_Ins_Pnt is new System.Address_To_Access_Conversions
        (Push_Instruction);
      use Thumb_Ins_Pnt;
      Temp_Ins : Object_Pointer;
   begin
      --loop over program code at start of hardfaulthandler
      for I in 0 .. PC_Offset when (I mod 2 = 0) loop
         Temp_Ins := To_Pointer (Hardfault_Handler'Address + I);
         -- is this a push instruction?
         if Temp_Ins.Mask = PUSH_Ins_Mask then
            -- yes, count number of regs we pushed to stack
            for Bit of Temp_Ins.Regs when Bit = True loop
               Num_Of_Pushed_Regs := Num_Of_Pushed_Regs + 1;
            end loop;
            -- alter back SP to Point before push (+ because stack grows down)
            SP_Calc := SP_Calc + 4 * Integer_Address (Num_Of_Pushed_Regs);

            declare
               Old_Regs : constant Stacked_Registers with
                 Import, Address => To_Address (SP_Calc + Stacked_Reg_Offset);
               Old_PC_Content : constant Thumb_Instruction with
                 Import, Address => Old_Regs.PC;
            begin
               if Old_PC_Content = Break_Point_Instruction then
                  -- Hardfault happend because no Debugger is connected,
                  -- just return
                  return;
               end if;
            end;
         end if;
      end loop;

      Put_Line ("Hard Fault");
      -- fault handling to be done
   end Hardfault_Handler;

Output of objdump:

 08000754 <m0__startup__hardfault_handler>:
   procedure Hardfault_Handler is
 8000754:       b5f8            push    {r3, r4, r5, r6, r7, lr}

   function Get_Stack_Pointer return Address is
      Result : Address;
   begin
      Asm
 8000756:       46ec            mov     ip, sp
   end Get_Stack_Pointer;

   function Get_Program_Counter return Address is
      Result : Address;
   begin
      Asm
 8000758:       467d            mov     r5, pc
      PC_Offset          : Storage_Offset  := PC - Hardfault_Handler'Address;
 800075a:       4e2a            ldr     r6, [pc, #168]  ; (8000804 <m0__startup__hardfault_h
andler+0xb0>)
   end "-";

Here the value for Hardfault_Handler"Address stored @8000804

    8000802:       bdf8            pop     {r3, r4, r5, r6, r7, pc}
 8000804:       08000755        stmdaeq r0, {r0, r2, r4, r6, r8, r9, sl}
 8000808:       08002a88        stmdaeq r0, {r3, r7, r9, fp, sp}
 800080c:       7fffffff        svcvc   0x00ffffff
 8000810:       0000beab        andeq   fp, r0, fp, lsr #29
 8000814:       08002a28        stmdaeq r0, {r3, r5, r9, fp, sp}
 8000818:       08002ad8        stmdaeq r0, {r3, r4, r6, r7, r9, fp, sp}

from inside gdb it looks like this:

also this is my vector table, the addresses are different too. But the reset handler, gets called and runs fine :

 Vector_Table : constant Address_Array :=
     (Sram_Stack_Start, Reset_Handler'Address, NMI_Handler'Address,
      Hardfault_Handler'Address, MemManage_Handler'Address,
      Bus_Fault_Handler'Address, Usage_Fault_Handler'Address, Reserved,
      Reserved, Reserved, Reserved, SVCall_Handler'Address,
      Debug_Handler'Address, Reserved, PendSV_Handler'Address,    
      Systick_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address, Default_Handler'Address,
      Default_Handler'Address);
   --Default_Handler'Address);
   pragma Linker_Section (Vector_Table, "_vector_table");

08000000 <m0__startup__vector_table>:
 8000000:       20001000        andcs   r1, r0, r0
 8000004:       080005b1        stmdaeq r0, {r0, r4, r5, r7, r8, sl}
 8000008:       08000699        stmdaeq r0, {r0, r3, r4, r7, r9, sl}
 800000c:       08000755        stmdaeq r0, {r0, r2, r4, r6, r8, r9, sl}
 8000010:       080006b1        stmdaeq r0, {r0, r4, r5, r7, r9, sl}
 8000014:       080006c9        stmdaeq r0, {r0, r3, r6, r7, r9, sl}
 8000018:       080006e1        stmdaeq r0, {r0, r5, r6, r7, r9, sl}
        ...

080005b0 <Reset_Handler>:

   -------------------
   -- Reset_Handler --
   -------------------

   procedure Reset_Handler is
 80005b0:       b570            push    {r4, r5, r6, lr}
      Data_L : Storage_Element with
        Volatile, Import, External_Name => "__data_size";

      Data_Length : constant Storage_Offset := Addr2SO (Data_L'Address);

      Data_Load_Array : Storage_Array (1 .. Data_Length) with
 80005b2:       4c16            ldr     r4, [pc, #88]   ; (800060c <Reset_Handler+0x5c>)
      Bss_L : Storage_Element with
        Volatile, Import, Convention => Asm, External_Name => "__bss_size";

Can someone explain this behavior?

I'm trying to use this API from the blockfrost: https://docs.blockfrost.io/#tag/Cardano-Transactions/paths/~1txs~1%7Bhash%7D~1utxos/get

but the problem is that sometimes I have more inputs than outputs and I don't know which one has the reference like per example in the https://cexplorer.io/tx that shows the user that spends the ADA and where it goes to another wallet, or cexplorer has other API for this purpose? :( Any help, please?

goes: have the transaction input having some variable that can refer to the output to separate each one in a new object to show in a table

I'm trying to write a simple machine learning application in Ada, and also trying to find a good framework to use. My knowledge of one thing is extremely minimal, and of the other is somewhat minimal.

There are several nifty machine learning frameworks out there, and I'd like to leverage one for use with an Ada program, but I guess I'm just...at a loss. Can I use an existing framework written in Python, for instance and wrap (or I guess, bind?) the API calls in Ada? Should I just pass off the scripting capabilities? I'm trying to figure it out.

Case in point: Scikit (sklearn) https://scikit-learn.org/stable/tutorial/text_analytics/working_with_text_data.html#

This does some neat stuff, and I'd like to be able to leverage this, but with an Ada program. Does anyone have advice from a similar experience?

I am just researching, so I have tried finding information.

http://www.inspirel.com/articles/Ada_Python_Binding.html https://scikit-learn.org/stable/tutorial/text_analytics/working_with_text_data.html#

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?

I am trying to write a library for AVX2 in Ada 2012 using the GNAT GCC compiler. I have currently defined a data type Vec_256_Integer_32 like so:

type Vector_256_Integer_32 is array (0 .. 7) of Integer_32;
pragma Pack(Vec_256_Integer_32);

Note that I have aligned the array according to the 32 byte boundary indicated in Intel's documentation of the _mm256_load_si256 intrinsic function from immintrin.h.

I would like to implement an operation that adds two of these arrays together using AVX2. The function prototype is as follows.

function Vector_256_Integer_32_Add (Left, Right : Vector_256_Integer_32) return Vector_256_Integer_32

My idea for implementing this function is to do this in three steps.

1. Load a and b using _mm256_load_si256 into a local variable.
2. Perform the addition operation using _mm256_add_epi32.
3. Convert the result back into the Vec_256_Unsigned_32 type using _mm256_store_si256.

Where I am confused is how I would create the __m256i data type in Ada to hold the intermediate results. Can someone please shed some light on this? Additionally, if you see any issues with my approach, any feedback is appreciated.

I have found the definition of __m256i in GCC (located at gcc/gcc/config/i386/avxintrin.h).

typedef long long __m256i __attribute__ ((__vector_size__ (32), __may_alias__));

However, here is where I am stuck as I am not sure how I would transfer this to Ada code. I have found that the __vector_size__ attribute is documented here.