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.

This note covers some of the considerations that’ll apply when running Alire on macOS.

According Ada2012 RM Assertion_Policy:

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

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

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

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

I 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;

There are lots of easy to understand recursive algorithms. One of the easiest is is a function sum(x) which sums up all the integers from 1 to x. Here is the function implemented in Ada.

function sum(n: integer) return integer is
begin
   if n = 1 then 
      return 1;
   else 
      return (n + sum(n-1));
   end if;
end sum;

Here the function sum(x) recurses until the value of x becomes 0. At this point the recursion is essentially done, and the calls to sum() backtrack. This is shown in the summary below for sum(5).

sum(5) = (5 + sum(4))                          recursive call sum(4)
       = (5 + (4 + sum(3)))                    recursive call sum(3)
       = (5 + (4 + (3 + sum(2))))              recursive call sum(2)
       = (5 + (4 + (3 + (2 + sum(1)))))        recursive call sum(1), return 1
       = (5 + (4 + (3 + (2 + 1))))             return (2 + 1)
       = (5 + (4 + (3 + 3)))                   return (3 + 3)
       = (5 + (4 + 6))                         return (4 + 6)
       = (5 + 10)                              return (5 + 10)
       = 15

There are four recursive calls to sum() in addition to the original call, which is not considered recursive, because the function may actually terminate, e.g. if sum(1) is invoked. So if the function were to call sum(10000), there would be 9,999 recursive calls. The problem with recursion of course is that many of these simplistic algorithms are just as easy to implement as iterative algorithms.

Here is the same algorithm represented iteratively:

function sumi(n: integer) return integer is
   s : integer;
begin
   s := 0;
   for i in 1..n loop
      s := s + i;
   end loop;
   return s;
end sumi;

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.