I'm currently learning Ada during a university course on real-time programming languages and have a question about SPARK.
I'm working on a project with a task that monitors an off-grid power supply. This task is crucial for machine safety and should therefore be as error free as possible, say proven with SPARK.
I get this weird error that I was not able to find a fix for 11:14 tasking in SPARK requires sequential elaboration (SPARK RM 9(2)) violation of pragma SPARK_Mode
The original code is a little long but I was able to get the same error with a minimal example.
The specification:
pragma Profile (Ravenscar);
pragma SPARK_Mode;
with System;
package simple_monitoring is
function sign (val : in Float) return Float
with Pre => val >= 10.0;
task type myTask is
end myTask;
end simple_monitoring;
The implementation:
pragma Profile (Ravenscar);
pragma SPARK_Mode;
with Ada.Real_Time; use Ada.Real_Time;
with Ada.Text_IO; use Ada.Text_IO;
package body simple_monitoring is
function sign (val : in Float) return Float is
res : Float;
begin
pragma Assert (val >= 10.0);
res := 100.0 / val;
return res;
end sign;
task body myTask is
TASK_PERIOD : constant Time_Span := Milliseconds (100);
next_time : Time := Clock;
myVar : Float;
begin
loop
Put_Line ("Running task");
myVar := sign (20.0);
next_time := next_time + TASK_PERIOD;
delay until next_time;
end loop;
end myTask;
end simple_monitoring;
Any help is appreciated :-)
You need the extra configuration pragma
pragma Partition_Elaboration_Policy (Sequential);
(see ARM H.6). For the example you give, this only needs to be placed on the spec; but in general it needs to be a program-wide configuration pragma.
You arrange this by having a file, say gnat.adc, containing for example
pragma Profile (Ravenscar);
pragma Partition_Elaboration_Policy (Sequential);
and referencing it in package Builder in your GNAT project file:
package Builder is
for Global_Configuration_Pragmas use "gnat.adc";
...
Related
I found this question and the first answer contains some example code demonstrating how to start an executable with Ada code. The output of the executable is written to the standard output.
What options do I have to read the output of the executable for further parsing/processing in Ada (for example line by line)?
If you use GNAT, then you might want to take a look at Get_Command_Output in the GNAT.Expect package. Here's an example:
with Ada.Text_IO, GNAT.Expect;
procedure Main is
Command : constant String := "gnat";
Argument_1 : aliased String := "--version";
Input : constant String := "";
Status : aliased Integer := 0;
-- Execute the command and retrieve the output.
Output : String :=
GNAT.Expect.Get_Command_Output
(Command => Command,
Arguments => (1 => Argument_1'Unchecked_Access),
Input => Input,
Status => Status'Access,
Err_To_Out => False);
-- NOTE: Cheating with Unchecked_Access, OK for demo. You may want
-- to properly new and Free these strings (see Argument_List
-- type in package GNAT.OS_Lib).
begin
Ada.Text_IO.Put_Line (Output);
end Main;
The program returns after execution:
$ ./main
GNAT Community 2019 (20190517-83)
Copyright (C) 1996-2019, Free Software Foundation, Inc.
This is free software; see the source for copying conditions.
There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
As can be seen, the result is returned as a single string. You will have do the line splitting yourself.
Update
An update in response to some comments below.
You might also consider using the system function if you're targeting the Windows platform (see also this post on SO). Quoting from the function reference:
The system function passes command to the command interpreter, which executes the string as an operating-system command.
This is similar to what the program cmd.exe does. You can obtain the output of the command by redirecting its output to a file (i.e. using >) and then subsequently read it back. Here's an example:
with Ada.Text_IO;
with Ada.Text_IO.Unbounded_IO;
with Ada.Strings.Unbounded;
with Interfaces.C;
with Interfaces.C.Strings;
procedure Main is
use Ada.Strings.Unbounded;
Content : Unbounded_String := Null_Unbounded_String;
begin
-- Execute.
declare
use Interfaces.C;
use Interfaces.C.Strings;
function system (command : chars_ptr) return int
with Import, Convention => C, External_Name => "system";
command : chars_ptr := New_String("gnat --version > gnat_version.out");
result : int := system (command);
begin
-- Check value of result (omitted in this example).
Free(Command);
end;
-- Read.
declare
use Ada.Text_IO;
use Ada.Text_IO.Unbounded_IO;
Fd : File_Type;
begin
Open (Fd, In_File, "./gnat_version.out");
while not End_Of_File (Fd) loop
Content := Content
& Unbounded_String'(Get_Line (Fd))
& ASCII.CR & ASCII.LF; -- Restore the line break removed by Get_Line.
end loop;
Close (fd);
end;
-- Show.
Ada.Text_IO.Unbounded_IO.Put (Content);
end Main;
I have an unusual situation in which elaboration code is simply not being executed at all. This is not an elaboration order issue, but rather an elaboration at all issue.
The problem is that I don't "with" the unit in question whatsoever, yet in theory it should still be accessible, as long as its elaboration occurs.
Of course I could just add a useless "with" for the unit in question, but in my real use case there are a large number of units that I would have to do that with.
My question is if there is any way either in the code, through pragmas, in the gpr project file, or through command-line switches that I could force the compiler to include a file even though it thinks the file isn't referenced?
Here is a minimal working example:
as.ads:
package As is
type A is tagged null record;
type Nothing is null record;
function Create (Ignored : not null access Nothing) return A;
function Image (From : A) return String;
end As;
as.adb:
package body As is
function Create (Ignored : not null access Nothing) return A is
(null record);
function Image (From : A) return String is ("A");
end As;
finder.ads:
with Ada.Tags;
package Finder is
procedure Register (Name : String; Tag : Ada.Tags.Tag);
function Find (Name : String; Default : Ada.Tags.Tag) return Ada.Tags.Tag;
end Finder;
finder.adb:
with Ada.Containers.Indefinite_Vectors;
package body Finder is
type Name_Tag (Size : Natural) is
record
Name : String (1 .. Size);
To : Ada.Tags.Tag;
end record;
package Name_Tag_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Name_Tag);
Name_Tags : Name_Tag_Vectors.Vector := Name_Tag_Vectors.Empty_Vector;
procedure Register (Name : String; Tag : Ada.Tags.Tag) is begin
Name_Tags.Append ((Name'Length, Name, Tag));
end Register;
function Find (Name : String; Default : Ada.Tags.Tag) return Ada.Tags.Tag is begin
for Tag of Name_Tags loop
if Tag.Name = Name then
return Tag.To;
end if;
end loop;
return Default;
end Find;
end Finder;
bs.ads:
with As;
package Bs is
type B is new As.A with null record;
function Create (Ignored : not null access As.Nothing) return B;
function Image (From : B) return String;
end Bs;
bs.adb:
with Finder;
package body Bs is
function Create (Ignored : not null access As.Nothing) return B is
(As.Create (Ignored) with null record);
function Image (From : B) return String is ("B");
begin
Finder.Register ("B", B'Tag);
end Bs;
test.adb:
with As; use As;
-- with Bs; -- (uncommenting this line solves my problem, but what if I had the rest of the alphabet?)
with Finder;
with Ada.Tags.Generic_Dispatching_Constructor;
with Ada.Text_IO;
procedure Test is
function Constructor is new Ada.Tags.Generic_Dispatching_Constructor (
T => A,
Parameters => Nothing,
Constructor => Create);
Nada : aliased Nothing := (null record);
What : A'Class := Constructor (Finder.Find ("B", A'Tag), Nada'Access);
begin
Ada.Text_IO.Put_Line (What.Image);
end Test;
The compiler thinks your package Bs isn't referenced because it isn't. You don't have a with clause for it, so it's not part of your program.
A simple example:
a.ads
package A is
procedure Blah;
end A;
a.adb
with Ada.Text_IO;
package body A is
procedure Blah is begin null; end Blah;
begin
Ada.Text_IO.Put_Line("Elaborate A");
end A;
b.ads
package B is
procedure Blah;
end B;
b.adb
with Ada.Text_IO;
package body B is
procedure Blah is begin null; end Blah;
begin
Ada.Text_IO.Put_Line("Elaborate B");
end B;
main.adb
with Ada.Text_IO;
with A;
procedure Main is
begin
Ada.Text_IO.Put_Line("Main");
end Main;
When I run main, it prints
Elaborate A
Main
It doesn't print Elaborate B because that package isn't part of the program; it's just a couple of source files in the same directory.
The obvious solution is to add the with clauses.
I don't know whether there's a less obvious solution. If there is, it's probably compiler-specific. But I'm not sure why a compiler would have a feature that lets you incorporate an otherwise unused package into a program.
What I’ve done (e.g. here ff) is to actually reference the units in the main program (with pragma Unreferenced to prevent warnings).
Alternatively, you could have a package e.g. Required_Units with all the necessary withs included, and then with that from the main program.
Even if there was some alternative process, you’d have to tell it what units you need to have included; might as well go with the flow and do it in Ada!
Since the package Bs is invisible to your program, so is the type B.
So the next question is: why do you need to register type B if it is not used anywhere?
If an Ada compiler did elaborate all units (packages or standalone subprograms) that are irrelevant to a main program, but are visible through source path, it would become really messy!...
I'm currently learning Ada during a university course on real-time programming languages and have a question about SPARK.
I'm working on a project with a task that monitors an off-grid power supply. This task is crucial for machine safety and should therefore be as error free as possible, say proven with SPARK. I was able to get a few things running with other questions on stackoverflow but I still run into errors that I was not able to fix with quick searches in the user guide.
The error is call to a volatile function in interfering context is not allowed in SPARK with reference to the line if monitoring_interface.is_all_config_set then ... in
task body monitoring_task is
next_time : Time;
begin
-- Initialisation of next execution time
next_time := Clock;
-- Superloop
loop
Put_Line ("Run task monitoring");
-- Load monitor configuration
monitor_pfc_voltage.config := monitoring_interface.get_monitor_pfc_voltage_config;
monitor_pfc_current.config := monitoring_interface.get_monitor_pfc_current_config;
monitor_output_voltage.config := monitoring_interface.get_monitor_output_voltage_config;
monitor_output_current.config := monitoring_interface.get_monitor_output_current_config;
-- Check if module has been configured correctly
-- Don't do anything otherwise
if monitoring_interface.is_all_config_set then -- <= erroneous line
do_monitoring;
end if;
next_time := next_time + TASK_PERIOD;
delay until next_time;
end loop;
end monitoring_task;
The function is_all_config_set is defined within a protected type that I use for inter task communication.
package PSU_Monitoring is
... Declaration of some types (Monitor_Config_T) ...
protected type Monitoring_Interface_T is
function is_all_config_set return Boolean;
procedure set_monitor_pfc_voltage_config (new_monitor_config : in Monitor_Config_T);
function get_monitor_pfc_voltage_config return Monitor_Config_T;
procedure set_monitor_pfc_current_config (new_monitor_config : in Monitor_Config_T);
function get_monitor_pfc_current_config return Monitor_Config_T;
procedure set_monitor_output_voltage_config (new_monitor_config : in Monitor_Config_T);
function get_monitor_output_voltage_config return Monitor_Config_T;
procedure set_monitor_output_current_config (new_monitor_config : in Monitor_Config_T);
function get_monitor_output_current_config return Monitor_Config_T;
private
-- Configuration for PFC intermediate voltage
monitor_pfc_voltage_config : Monitor_Config_T;
monitor_pfc_voltage_config_set : Boolean := False;
-- Configuration for PFC inductor current
monitor_pfc_current_config : Monitor_Config_T;
monitor_pfc_current_config_set : Boolean := False;
-- Configuration for output voltage
monitor_output_voltage_config : Monitor_Config_T;
monitor_output_voltage_config_set : Boolean := False;
-- Configuration for output inductor current
monitor_output_current_config : Monitor_Config_T;
monitor_output_current_config_set : Boolean := False;
end Monitoring_Interface_T;
monitoring_interface : Monitoring_Interface_T;
private
... Declaration of a task and some private constants and subprograms ...
end PSU_Monitoring
The respective body is
package body PSU_Monitoring is
protected body Monitoring_Interface_T is
function is_all_config_set return Boolean is
begin
return monitor_pfc_voltage_config_set and monitor_pfc_current_config_set and monitor_output_voltage_config_set and monitor_output_current_config_set;
end is_all_config_set;
procedure set_monitor_pfc_voltage_config (new_monitor_config : in Monitor_Config_T) is
begin
monitor_pfc_voltage_config := new_monitor_config;
monitor_pfc_voltage_config_set := True;
end set_monitor_pfc_voltage_config;
function get_monitor_pfc_voltage_config return Monitor_Config_T is
begin
return monitor_pfc_voltage_config;
end get_monitor_pfc_voltage_config;
procedure set_monitor_pfc_current_config (new_monitor_config : in Monitor_Config_T) is
begin
monitor_pfc_current_config := new_monitor_config;
monitor_pfc_current_config_set := True;
end set_monitor_pfc_current_config;
function get_monitor_pfc_current_config return Monitor_Config_T is
begin
return monitor_pfc_current_config;
end get_monitor_pfc_current_config;
procedure set_monitor_output_voltage_config (new_monitor_config : in Monitor_Config_T) is
begin
monitor_output_voltage_config := new_monitor_config;
monitor_output_voltage_config_set := True;
end set_monitor_output_voltage_config;
function get_monitor_output_voltage_config return Monitor_Config_T is
begin
return monitor_output_voltage_config;
end get_monitor_output_voltage_config;
procedure set_monitor_output_current_config (new_monitor_config : in Monitor_Config_T) is
begin
monitor_output_current_config := new_monitor_config;
monitor_output_current_config_set := True;
end set_monitor_output_current_config;
function get_monitor_output_current_config return Monitor_Config_T is
begin
return monitor_output_current_config;
end get_monitor_output_current_config;
end Monitoring_Interface_T;
... Definition of the remaining subprograms defined in the specification file ...
end PSU_Monitoring;
What is the problem here?
As Jeffrey was saying, we need to see the part of the program where the error is flagged. In general, this is related to functions with side effects, see reference manual:
http://docs.adacore.com/spark2014-docs/html/lrm/packages.html#external-state-variables
The same error message can be observed if you use the Clock function from the Real-Time package in the "wrong" way:
with Ada.Real_Time; use Ada.Real_Time;
with Ada.Text_IO; use Ada.Text_IO;
procedure Main with SPARK_Mode is
Last : Time := Clock;
begin
-- some stuff happening here ...
if Clock > Last + Milliseconds(100) then
Put_Line("Too late");
end if;
end Main;
Clock is a function that has side effects (it returns different values every time you call it), and in this example the function is used in what's called an "interfering context" (see link above for a definition).
The solution would be to rewrite your code slightly:
with Ada.Real_Time; use Ada.Real_Time;
with Ada.Text_IO; use Ada.Text_IO;
procedure Main with SPARK_Mode is
Last : Time := Clock;
begin
-- some code
declare
now : Time := Clock;
begin
if now > Last + Milliseconds(100) then
Put_Line("Too late");
end if;
end;
end Main;
So, basically, what you do is isolate calls to functions with side effects into a separate statement, saving the result in a variable, and then use the variable where you had your call before. This trick should help with your call to the protected object, as well.
I'm interfacing to a USB device (on Debian Stretch) using hidraw, and I need to process some information supplied by the USB device in the form of wchar_t* which I need to convert into (Ada) Wide_String. This is giving some trouble and I'm not seeing a clean way forward using the facilities in Interfaces.C and Interfaces.C.Strings.
All files are edited down without destroying their consistency. They will build, but without one of these, they won't actually run.
The problem is that device information like Serial Number and Product Name are presented by the Linux device driver as an access stddef_h.wchar_t from which I want to return a Wide_String or even a normal String) and I'm not seeing any good way to get there.
Interfaces.C.Strings has function Value (Item : in chars_ptr) return String; but no equivalent exists for Wide_String that I can see. So I think I need an equivalent Value function for wide characters.
The approach below uses To_Ada (from Interfaces.C) to return a Wide_String given a wchar_array. It fails, of course, because an access wchar_t is not convertible to a wchar_array.
-- helper function to deal with wchar_t * to wide_string
function Value (P : access stddef_h.wchar_t) return Wide_String is
temp : Wide_String(1 .. 256);
count : natural := 0;
-- ugliness to convert pointer types
type sd_wchar_ptr is access all stddef_h.wchar_t;
type wchar_array_ptr is access wchar_array;
Function To_Wchar_Array_Ptr is new Ada.Unchecked_Conversion(sd_wchar_ptr, wchar_array_ptr);
-- this does NOT create the required wchar_array pointer
WCP : wchar_array_ptr := To_Wchar_Array_Ptr(sd_wchar_ptr(P));
begin
Put_Line("Wide string");
To_Ada(WCP.all, temp, count);
Put_Line("Wide string length " & natural'image(count));
return temp(1..count);
end Value;
and the inevitable result
./test_hid
Wide string
Execution terminated by unhandled exception raised STORAGE_ERROR :
stack overflow or erroneous memory access
A similar character by character approach would be possible ... if (and I can't believe I'm saying this!) you could increment access types...
Feels like there's something missing from Interfaces.C here... what am I missing? any ideas to get round this relatively trivial seeming stumbling block?
EDIT : I'm leaning towards some brazen theft from the Interfaces.C.Strings sources with appropriate changes, but I'd welcome alternative suggestions.
The rest of this below is the full story so far (including all code necessary to reproduce)
Step 1 : generate low level Ada bindings automatically using gcc.
gcc -c -fdump-ada-spec-slim /usr/include/hidapi/hidapi.h
producing the low level binding package hidapi_hidapi_h
pragma Ada_2005;
pragma Style_Checks (Off);
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings;
with stddef_h;
with System;
package hidapi_hidapi_h is
-- see source file /usr/include/hidapi/hidapi.h
type hid_device_info is record
path : Interfaces.C.Strings.chars_ptr; -- /usr/include/hidapi/hidapi.h:51
vendor_id : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:53
product_id : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:55
serial_number : access stddef_h.wchar_t; -- /usr/include/hidapi/hidapi.h:57
release_number : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:60
manufacturer_string : access stddef_h.wchar_t; -- /usr/include/hidapi/hidapi.h:62
product_string : access stddef_h.wchar_t; -- /usr/include/hidapi/hidapi.h:64
usage_page : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:67
usage : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:70
interface_number : aliased int; -- /usr/include/hidapi/hidapi.h:75
next : access hid_device_info; -- /usr/include/hidapi/hidapi.h:78
end record;
pragma Convention (C_Pass_By_Copy, hid_device_info); -- /usr/include/hidapi/hidapi.h:49
function hid_enumerate (arg1 : unsigned_short; arg2 : unsigned_short) return access hid_device_info; -- /usr/include/hidapi/hidapi.h:132
pragma Import (C, hid_enumerate, "hid_enumerate");
end hidapi_hidapi_h;
This is a low level binding, exposing C types (and the binding generator has decided that the wchar_t in Interfaces.C isn't good enough, it wants one from stddef.h too, so...
pragma Ada_2005;
pragma Style_Checks (Off);
with Interfaces.C; use Interfaces.C;
package stddef_h is
-- unsupported macro: NULL ((void *)0)
subtype size_t is unsigned_long; -- /usr/lib/gcc/x86_64-linux-gnu/6/include/stddef.h:216
subtype wchar_t is int; -- /usr/lib/gcc/x86_64-linux-gnu/6/include/stddef.h:328
end stddef_h;
Because it is a low level binding; we want to hide it (and implement RAII etc) behind a simpler and more usable high level binding, so ... (below)
with Ada.Finalization; use Ada.Finalization;
private with hidapi_hidapi_h;
private with System;
package hidapi is
type id is new natural range 0 .. 2**16 - 1;
type hid_device is new Limited_Controlled with private;
-- find first matching devices by enumeration : the RA part of RAII.
function enumerate (vendor_id, product_id : id) return hid_device;
-- accessors for device characteristics on enumerated device
function Serial_No (D : hid_device) return Wide_String;
function Product_String (D : hid_device) return Wide_String;
private
type hid_device is new Limited_Controlled with record
member : access hidapi_hidapi_h.hid_device_info;
addr : System.Address;
end record;
end hidapi;
and its implementation, containing the problem function value to return a Wide_String.
with hidapi_hidapi_h;
with Interfaces.C; use Interfaces.C;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Conversion;
with stddef_h;
package body hidapi is
function enumerate (vendor_id, product_id : id) return hid_device is
use hidapi_hidapi_h;
first : access hid_device_info;
begin
first := hid_enumerate(unsigned_short(vendor_id), unsigned_short(product_id));
if first /= null then
return H : hid_device do
H.member := first;
H.addr := System.Null_Address;
end return;
else raise Program_Error;
end if;
end enumerate;
-- helper function to deal with wchar_t * to wide_string
function Value (P : access stddef_h.wchar_t) return Wide_String is
temp : Wide_String(1 .. 256);
count : natural := 0;
type sd_wchar_ptr is access all stddef_h.wchar_t;
type wchar_array_ptr is access wchar_array;
Function To_Wchar_Array_Ptr is new Ada.Unchecked_Conversion(sd_wchar_ptr, wchar_array_ptr);
WCP : wchar_array_ptr := To_Wchar_Array_Ptr(sd_wchar_ptr(P));
begin
Put_Line("Wide string");
To_Ada(WCP.all, temp, count);
Put_Line("Wide string length " & natural'image(count));
return temp(1..count);
end Value;
function Serial_No (D : hid_device) return Wide_String is
use hidapi_hidapi_h;
begin
return Value(D.member.serial_number);
end Serial_No;
function Product_String (D : hid_device) return Wide_String is
use hidapi_hidapi_h;
begin
return Value(D.member.product_string);
end Product_String;
end hidapi;
And of course a test case to exercise it...
with Hidapi;
with Ada.Wide_Text_IO;
procedure Test_Hid is
usbrelay_vendor_id : constant Hidapi.id := 16#16c0#;
usbrelay_product_id : constant Hidapi.id := 16#05df#;
Device : Hidapi.hid_device := Hidapi.Enumerate(usbrelay_vendor_id, usbrelay_product_id);
begin
Ada.Wide_Text_IO.Put_Line("Serial : " & Device.Serial_No);
Ada.Wide_Text_IO.Put_Line("Product : " & Device.Product_String);
end Test_Hid;
One answer, slavishly copying the approach in the package body for Tnterfaces.C.Strings with necessary changes.
The naughty stuff is in functions "+" and Peek which use Unchecked Conversions on pointers,
to permit address arithmetic. Not pointer increment, but pointer+offset. One change is that the offset has to be scaled for 4 byte characters. I haven't set that scaling in a portable manner, but note that "+" will overload for each different return type so that offsets will be scaled appropriately for different named access types.
to allow the stddef_h.wchar_t to be viewed as a Wide_Wide_Character in the absence of any type conversion function. Whether the representation is correct is another matter (here, it is) but this technique could also be used to fake the input type of a suitable conversion function like To_Ada in Interfaces.C.
The remainder is straightforward character by character handling. One other change (so far) is to return Wide_Wide_Character rather than Wide_Character (because as the stddef_h package above reveals, the stored characters are 32 bit, same size as Interfaces.C.int. I'm happy to change my interface, but Wide_String could be easily handled by Ada.Strings packages.
type sd_wchar_ptr is access all stddef_h.wchar_t;
type w_w_char_ptr is access all char32_t;
-- Two Unchecked_Conversions to allow pointer arithmetic
-- And a third to allow the resulting storage to be interpreted as Wide_Wide_Char
function To_Sd_wchar_ptr is new Ada.Unchecked_Conversion (System.Address, sd_wchar_ptr);
function To_Address is new Ada.Unchecked_Conversion (sd_wchar_ptr, System.Address);
function To_Wchar_Ptr is new Ada.Unchecked_Conversion (sd_wchar_ptr, w_w_char_ptr);
-- pointer + offset arithmetic, with offset scaled for size of stddef_h.wchar_t;
-- TODO: attempted better way of computing word size ran into type errors
function "+" (Left : sd_wchar_ptr; Right : size_t) return sd_wchar_ptr is
begin
return To_Sd_wchar_ptr (To_Address (Left) + Storage_Offset (Right) * 4);
end "+";
function Peek (From : sd_wchar_ptr) return char32_t is
begin
return To_Wchar_Ptr(From).all;
end Peek;
function Strlen (Item : sd_wchar_ptr) return size_t is
Item_Index : size_t := 0;
begin
if Item = Null then
raise Program_Error;
end if;
loop
if Peek (Item + Item_Index) = char32_nul then
return Item_Index;
end if;
Item_Index := Item_Index + 1;
end loop;
end Strlen;
function Value (Item : sd_wchar_ptr) return char32_array is
Result : char32_array (0 .. Strlen (Item));
begin
if Item = Null then
raise Program_Error;
end if;
Put_Line("String length " & size_t'image(Strlen(Item)));
-- Note that the following loop will also copy the terminating Nul
for J in Result'Range loop
Result (J) := Peek (Item + J);
end loop;
return Result;
end Value;
-- helper function to deal with wchar_t * to wide_wide_string
function Value (Item : access stddef_h.wchar_t) return Wide_Wide_String is
begin
return To_Ada (Value (sd_wchar_ptr(Item)));
end Value;
How do I fix this Seg Fault in my DLL?
I'm generating a Windows DLL (in Ada) and using the DLL from an Ada
program. I’m using AdaCore’s GNAT GPS v6.0.1 IDE for both the DLL
and an Ada program to test the DLL, running on a Windows 7 machine.
Two separate project files are used, one for the DLL, the other for
the test driver. The DLL does not have any DLLMain nor initialization
or finalization routines.
As a first step (because I've never created a DLL or used GPS prior to this, do know some Ada though), I coded two very simple functions for the DLL. One function returns a pointer to a string, the other function returns a fixed length string.
The test program successfully calls the DLL function that returns a fixed-length
string, however when calling the function that returns a string pointer, a
segmentation fault occurs. Here is the gcc debug output:
Program received signal SIGSEGV, Segmentation fault.
0x6b81dd2c in system.secondary_stack.ss_mark () from C:\GNAT\2014\bin\libgnat-2014.dll
(gdb) quit
Here is the code:
DLL Spec
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
package String_Utils is
type String_Ptr_T is access String;
type Spec_Str is new String (1..7);
function Int_Trim_Left( IntToTrim : Integer) return String_Ptr_T;
pragma Export(DLL, Int_Trim_Left, "String_Utils__Int_Trim_Left");
function Spec( Input_Int : Integer) return Spec_Str;
pragma Export(DLL, Spec, "String_Utils__Spec");
end String_Utils;
DLL Body
package body String_Utils is
function Int_Trim_Left( IntToTrim : Integer) return String_Ptr_T is
String_Ptr : String_Ptr_T;
begin
Text_IO.Put_Line("About to call new String in DLL.");
String_Ptr := new String'(
Ada.Strings.Fixed.Trim(Integer'Image(IntToTrim),
Ada.Strings.Left));
return String_Ptr;
end;
--
function Spec( Input_Int : Integer) return Spec_Str
is
Result_Spec : String := "ABC-UNK";
begin
case Input_Int is
when 1 => return "ABC-STD"; -- Standard
when 2 => return "ABC-PRF"; -- Performance
when 3 => return "DEF-DTL"; -- Detailed
when Others => return "ABC-UNK";
end case;
end;
DLL Project File
project HAGUtils is
for Library_Name use "HAGUtils";
for Library_Dir use "libdir";
for Library_Version use "0.01";
for Library_Kind use "dynamic";
for Object_Dir use "obj";
for Source_Dirs use ("src");
for Source_Files use ("string_utils.adb", "string_utils.ads");
end HAGUtils;
Test Driver
-- Driver for DLL
with Text_IO; use Text_IO;
procedure test_ada_dll is
type String_Ptr_T is access String;
subtype String7 is String(1..7);
input_val : Integer := 0;
Spec_Str : String7 := (Others => ' ');
Int_String_Ptr : String_Ptr_T:= null;
-- Import
function Int_Trim_Left ( IntToTrim : Integer) return String_Ptr_T
is
function Inner_Int_Trim_Left ( IntToTrim : Integer) return String_Ptr_T;
pragma Import (DLL, Inner_Int_Trim_Left, "String_Utils__Int_Trim_Left");
begin
return Inner_Int_Trim_Left (IntToTrim);
end Int_Trim_Left;
-- Import
function Spec ( Input_Int : Integer) return String7
is
function Inner_Spec ( Input_Int : Integer) return String7;
pragma Import (DLL, Inner_Spec, "String_Utils__Spec");
begin
return Inner_Spec (Input_Int);
end Spec;
begin
input_val := 3;
Spec_Str := Spec(input_val);
Text_IO.Put_Line("The Spec is -- " & Spec_Str);
Text_IO.Put_Line("Calling Int_Trim_Left with --" & Integer'Image(input_val));
Int_String_Ptr := Int_Trim_Left(input_val);
Text_IO.Put_Line("After call --" & Int_String_Ptr.all);
end;
I think that the SEGV happened because your DLL wasn’t initialized. The Ada runtime system needs initialization, which in the absence of DLLs would be called up in the GNAT bind process (you may have seen calls to gnatbind or gprbind flashing up the screen).
However, you have a DLL that requires the RTS to be initialized (the part that deals with the secondary stack, which is where GNAT constructs temporary unconstrained objects such as strings); but the binder isn’t aware of this because of the way you’ve linked your program (you don’t say, but I suspect you’ve specified the DLL via -lHAGutils?).
The way to get GNAT to handle this for you is to write a project file for the test program and have it with your DLL’s project:
with "HAGutils";
project Test_Ada_Dll is
for Main use ("test_ada_dll.adb");
for Exec_Dir use ".";
for Source_Files use ("test_ada_dll.adb");
for Object_Dir use ".build";
end Test_Ada_Dll;
This then makes the interfaces of HAGlib visible to test_ada_dll, so you can change it to say
with Text_IO; use Text_IO;
with String_Utils;
procedure test_ada_dll is
input_val : Integer := 0;
Spec_Str : String_Utils.Spec_Str := (Others => ' ');
Int_String_Ptr : String_Utils.String_Ptr_T:= null;
begin
input_val := 3;
Spec_Str := String_Utils.Spec(input_val);
Text_IO.Put_Line("The Spec is -- " & String (Spec_Str));
Text_IO.Put_Line("Calling Int_Trim_Left with --" & Integer'Image(input_val));
Int_String_Ptr := String_Utils.Int_Trim_Left(input_val);
Text_IO.Put_Line("After call --" & Int_String_Ptr.all);
end;
(note, the conversion in Text_IO.Put_Line("The Spec is -- " & String (Spec_Str)); is because Spec_Str is a derived type; I think it’s be more normal in this case to make it a subtype).
Further, you no longer need to use the pragma Exports in String_Utils’s spec.
The result of this is that the binder is aware of the properties of your HAGutils DLL, and can arrange for the necessary initializations to happen.
There is a way in which you can make your original code work, which is to use the GPR attribute Library_Auto_Init in HAGutils.gpr:
for Library_Auto_Init use “true”;
but I think you’d have to make HAGlib a proper standalone library. This is quite complex to get right, and not necessary to get the library working to start with.