I am using avr-ada to compile my program. I want to right shift an unsigned_16 variable twice.
Interfaces.Shift_Right is overloaded and provides for both Unsigned_8 and Unisgned_16.
When I compile, I get the error 'expected type "Interfaces.Unsigned_8"', 'found type "Interfaces.Unsigned_16"'. I have tried to specify that the input is an Unsigned_16, but it won't work. How do I specify the correct function?
with AVR; use AVR;
with AVR.MCU;
with AVR.Timer0;
with AVR.ADC;
with Interfaces;
use Interfaces;
procedure Flash_Led is
adc_result_10 : Unsigned_16 := 0;
adc_result_8 : Unsigned_8 := 0;
begin
-- set OC0A pin as output, required for output toggling
MCU.DDRD_Bits := (others => DD_Output);
-- set all pins low
MCU.PortD := 16#00#;
-- clear register
MCU.TCCR0B := 16#00#;
-- initialize timer to Clear Timer on Compare, scale the input
-- clock and set a value to compare the timer against.
Timer0.Init_CTC (Timer0.Scale_By_1024, Overflow => 1);
-- Toggle the OC0(A)-Pin on compare match
Timer0.Set_Output_Compare_Mode_Toggle;
-- Initialize ADC
ADC.Init(ADC.Scale_By_64, Ref => ADC.Is_Vcc);
loop -- loop forever
adc_result_10 := ADC.Convert_10bit(Ch => 0);
adc_result_10 := Shift_Right(Unsigned_16'(adc_result_10), 2); --'
adc_result_8 := Unsigned_8(adc_result_10);
Timer0.Set_Overflow_At(adc_result_10);
end loop;
end Flash_Led;
The line:
Timer0.Set_Overflow_At(adc_result_10);
Should have been:
Timer0.Set_Overflow_At(adc_result_8);
I didn't look at the line number in the error message closely enough. Oops.
If you are unsure which function is being called (given that it is overloaded) you can always construct a unique name through renames...
function My16_Shift_Right (Item : in Unsigned_16; Amount : Natural) return Unsigned_16
renames Interfaces.Shift_Right;
and then test the way you are thinking about your program.
Related
I was expecting this program to raise an error when I feed it 3 as a valid Scale value, but no such luck:
with Ada.Text_IO; use Ada.Text_IO;
procedure predicate is
type Scale is new Integer
with Dynamic_Predicate => Scale in 1 | 2 | 4 | 8;
GivesWarning : Scale := 3; -- gives warning
begin
Put_Line ("Hello World");
loop
Put_Line ("Gimme a value");
declare
AnyValue : Integer := Integer'Value (Get_Line);
S : Scale := Scale (AnyValue); -- no check done!
begin
Put_Line ("okay, that works" & S'Image);
end;
end loop;
end predicate;
I found this related question, but there the requirement is to use an enum., and the solution is to define an array from enum -> value.
I want something that gives me at least a warning at compile time, and allows me to check at runtime as well, and that raises an error if I try to put an invalid value in. Then, if I can use SPARK to prove that no invalid values can occur, I could turn off said checks. I was under the impression that this was how Static_ / Dynamic_ predicates work, so the example above took me by surprise.
You need to enable assertions. Either compile with -gnata or set an appropriate Assertion_Policy
pragma Assertion_Policy(Dynamic_Predicate => Check);
I've tried searching the docs and the code, but I'm unable to find what this is and therefore how to correct it.
Scenario:
I'm using the Ada SPARK vectors library and I have the following code:
package MyPackage
with SPARK_Mode => On
is
package New_Vectors is new Formal_Vectors (Index_Type => test, Element_Type => My_Element.Object);
type Object is private;
private
type Object is
record
Data : New_Vectors.Vector (Block_Vectors.Last_Count);
Identifier : Identifier_Range;
end record;
I get the error when the code calls:
function Make (Identifier : Identifier_Range) return Object is
begin
return (
Data => New_Vectors.Empty_Vector,
Identifier => Identifier);
end Make;
Pointing to Empty_Vector. The difficulty is that Empty_Vector defines the Capacity as 0 which appears to be leading to the problem. Now I'm not sure then how to deal with that as Capacity seems to be in the type definition (having looked in a-cofove.ads).
So basically I'm stuck as to how to resolve this; or quite how to spot this happening in future.
Your analysis is correct. The error occurs because you attempt to assign an empty vector (i.e. a vector with capacity 0) to a vector with capacity Block_Vectors.Last_Count (which appears to be non-zero).
You actually do not need to initialize the vector explicitly in order to use it. A default initialization (using <>, see, for example, here) suffices as shown in de example below.
However, in order to prove the absence of runtime errors, you do need to explicitly clear the vector using Clear. The Empty_Vector function can then be used to in assertions that check if a vector is empty or not as shown in the example below. The example can be shown to be free of runtime errors using gnatprove. For example by opening the prove settings via menu SPARK > Prove in GNAT Studio, selecting "Report checks moved" in the "General" section (top left) and then running the analysis by selecting "Execute" (bottom right).
main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Containers.Formal_Vectors;
procedure Main with SPARK_Mode is
package My_Vectors is new Ada.Containers.Formal_Vectors
(Index_Type => Natural,
Element_Type => Integer);
use My_Vectors;
type Object is record
Data : Vector (Capacity => 10); -- Max. # of elements: 10
Value : Integer;
end record;
-- Initialize with default value (i.e. <>), no explicit initialization needed.
Obj : Object :=
(Data => <>,
Value => 42);
begin
-- Clear the vector, required for the assertions to be proven.
Clear (Obj.Data);
-- Assert that the vector is not empty.
pragma Assert (Obj.Data = Empty_Vector);
-- Populate the vector with some elements.
Append (Obj.Data, 4);
Append (Obj.Data, 5);
Append (Obj.Data, 6);
-- Assert that the vector is populated.
pragma Assert (Obj.Data /= Empty_Vector);
-- Show the contents of Obj.Data.
Put_Line ("Contents of Obj.Data:");
for I in Natural range 0 .. Natural (Length (Obj.Data)) - 1 loop
Put_Line ("[" & I'Image & "]" & Element (Obj.Data, I)'Image);
end loop;
New_Line;
-- or, alternatively using an iterator ...
declare
I : Extended_Index := Iter_First (Obj.Data);
begin
while Iter_Has_Element (Obj.Data, I) loop
Put_Line ("[" & I'Image & "]" & Element (Obj.Data, I)'Image);
I := Iter_Next (Obj.Data, I);
end loop;
end;
New_Line;
-- Show the contents of Obj.Value.
Put_Line ("Contents of Obj.Value:");
Put_Line (Obj.Value'Image);
New_Line;
end Main;
output
Contents of Obj.Data:
[ 0] 4
[ 1] 5
[ 2] 6
[ 0] 4
[ 1] 5
[ 2] 6
Contents of Obj.Value:
42
Issue:
How do I save an Access Pointer to a discriminant record for use later on in the program?
In main.adb (1) I demonstrate how I was able to get it to compile, but I get a runtime error:
raised PROGRAM_ERROR : main.adb:14 accessibility check failed
Note:
This is small example program based on a much larger/complex codebase.
Constraints:
i. The solution is required to be Ada95 Compatible.
ii. The solution must not change the package specification of Foo.ads as this is existing code that must be used as-is.
foo.ads
with Interfaces;
package Foo is
type Base_Class is abstract tagged limited private;
type Base_Class_Ref is access all Base_Class'Class;
for Base_Class_Ref'Storage_Size use 0;
Max_Count : constant := 6;
type Count_Type is new Interfaces.Unsigned_16 range 1 .. Max_Count;
type Foo_Class (Max : Count_Type) is new Base_Class with private;
type Foo_Class_Ref is access all Foo_Class;
for Foo_Class_Ref'Storage_Size use 0;
--
procedure Initialize (This_Ptr : Access Foo_Class);
--
function Get_Using_Pointer (This_Ptr : in Foo_Class_Ref) return Interfaces.Unsigned_16;
private
type Base_Class is abstract tagged limited null record;
type My_Data_Type is
record
X, Y, Z : Interfaces.Unsigned_16;
end record;
type My_Data_Array is
array (Count_Type range <>) of My_Data_Type;
type Foo_Class (Max : Count_Type) is new Base_Class with
record
Other_Data : Interfaces.Unsigned_16;
Data : My_Data_Array(1 .. Max);
end record;
end Foo;
foo.adb
package body Foo is
-- --------------------------------------------------------------------
procedure Initialize (This_Ptr : Access Foo_Class) is
begin
This_Ptr.Other_Data := 0;
This_Ptr.Data := (others => (0,0,0));
end Initialize;
-- --------------------------------------------------------------------
function Get_Using_Pointer (This_Ptr : in Foo_Class_Ref)
return Interfaces.Unsigned_16 is
begin
return This_Ptr.Other_Data;
end Get_Using_Pointer;
end Foo;
main.adb
-------------------------------------------------------------------------------
--
-- Issue:
-- How do I save an Access Pointer for later use (1) to a discriminent record?
--
-- Constraints:
-- i. The solution is required to be Ada95 Compatible.
-- ii. The solution must not change the package specification of Foo.ads
--
-------------------------------------------------------------------------------
--
with Interfaces;
with Foo;
procedure Main is
Foo_Count : constant := 3;
Foo_Obj : aliased Foo.Foo_Class (Max => Foo_Count);
procedure TEST (This_Ptr : access Foo.Foo_Class) is
-- (1) Save Pointer
-- **** This Line reports: ****
-- raised PROGRAM_ERROR : main.adb:14 accessibility check failed
Foo_Ptr : Foo.Foo_Class_Ref := This_Ptr.all'Access; -- This Compiles...
-- ^^^ I know that this is not correct.
-- But it was the only way I could find to get it to compile.
Data : Interfaces.Unsigned_16;
begin
-- (2) Get Data
Data := Foo.Get_Using_Pointer(This_Ptr => Foo_Ptr); -- This Compiles...
end;
begin
Foo.Initialize(This_Ptr => Foo_Obj'Access);
Test(This_Ptr => Foo_Obj'Access);
end Main;
Quick answer:
Foo_Ptr : Foo.Foo_Class_Ref := This_Ptr.all'Unchecked_Access;
Checked as far as I can with
lockheed:jerunh simon$ gnatmake main.adb -gnat95 -f
gcc -c -gnat95 main.adb
gcc -c -gnat95 foo.adb
gnatbind -x main.ali
gnatlink main.ali
lockheed:jerunh simon$ ./main
lockheed:jerunh simon$
In the line
Foo_Ptr : Foo.Foo_Class_Ref := This_Ptr.all'Access;
replace 'Access with 'Unchecked_Access.
PS. It could cause a dangling references if you destroy the object before Foo_Ptr gone.
The types Base_Class_Ref and Foo_Class_Ref are named access types and variables of this type can only refer to objects either on the heap or on package level, NOT objects on the stack. Since Storage_Size is set to zero it means the heap is out of the question.
package Main_App is
procedure Run;
end Main_App;
package body Main_App is
procedure TEST (This_Ptr : access Foo.Foo_Class) is
-- (1) Save Pointer
-- **** This Line reports: ****
-- raised PROGRAM_ERROR : main.adb:14 accessibility check failed
Foo_Ptr : Foo.Foo_Class_Ref := This_Ptr.all'Access; -- This Compiles...
-- ^^^ I know that this is not correct.
-- But it was the only way I could find to get it to compile.
Data : Interfaces.Unsigned_16;
begin
-- (2) Get Data
Data := Foo.Get_Using_Pointer(This_Ptr => Foo_Ptr); -- This Compiles...
end TEST;
Foo_Count : constant := 3;
Foo_Obj : aliased Foo.Foo_Class (Max => Foo_Count);
procedure Run is
begin
Foo.Initialize (This_Ptr => Foo_Obj'Access);
TEST (This_Ptr => Foo_Obj'Access);
end Run;
end Main_App;
with Main_App;
procedure Main is
begin
Main_App.Run;
end Main;
I hope this solution applicable to your use-case since it avoids usage of Unchecked_Access.
Ok what you're dealing with here is an anonymous access type, from the signature procedure TEST (This_Ptr : access Foo.Foo_Class). The error is telling you that this particular subprogram is in a deeper nesting than the thing it's pointing to: IOW, it could give you a dangling reference.
The proper solution, staying strictly in Ada95 would be to (A) put the TEST subprogram in the library unit [IIRC; 95 and 2005 are so similar they blur together]; or (B) put use a generic.
For a generic, IIRC, you can do this:
Generic
Object : Aliased Foo_Class'Class; -- Might not need 'Class.
with Function Operation(This_Ptr : in Foo_Class_Ref) return Interfaces.Unsigned_16;
Procedure Execute;
--...
Procedure Execute is
Result : Interfaces.Unsigned_16;
Begin
Result:= Operation( Object'Access );
End Execute;
----------------------------------------
O : Aliased Foo.Foo_Class(3);
Procedure TEST is new Foo.Execute( Operation => Foo.Get_Using_Pointer, Object => O );
This might require a little fiddling for your application, but if you put the generic inside Foo.ads/Foo.adb`, it should work. [IIRC] Aside from this, your best bet is to move your aliased object outside your main subprogram's declaration area, then it should work.
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;