Off-by-one bugs fixed, more testing programs, change to Integer_AddressHEADmaster

4 files changed, 268 insertions, 82 deletions

diff --git a/src/c_aao.c b/src/c_aao.c
index 7c6fe8d..3a18047 100644
--- a/src/c_aao.c
+++ b/src/c_aao.c
@@ -28,6 +28,12 @@ const int error_fail = AO_EFAIL;
 
 
 
+size_t c_pointer_size() {
+    return sizeof(void*);
+}
+
+
+
 ao_info * info_item_get(ao_info ** items, int n) {
     return items[n];
 }
diff --git a/src/c_aao.h b/src/c_aao.h
index 81f61ff..9e24cbc 100644
--- a/src/c_aao.h
+++ b/src/c_aao.h
@@ -28,6 +28,9 @@ extern const int error_bad_format;
 extern const int error_fail;
 
 
+size_t c_pointer_size();
+
+
 ao_info * info_item_get(ao_info ** items, int n);
 
 int info_kind_get(ao_info * item);
diff --git a/src/libao.adb b/src/libao.adb
index 48a0ac1..0d7f7ba 100644
--- a/src/libao.adb
+++ b/src/libao.adb
@@ -9,11 +9,15 @@ pragma Ada_2012;
 
 with
 
+    Ada.Containers,
+    Ada.Strings.Fixed,
+    Ada.Strings.Maps,
     Interfaces.C.Strings,
-    System;
+    System.Storage_Elements;
 
 use type
 
+    Ada.Containers.Count_Type,
     Interfaces.C.int,
     Interfaces.C.Strings.chars_ptr,
     System.Address;
@@ -22,6 +26,13 @@ use type
 package body Libao is
 
 
+    package Str  renames Ada.Strings;
+    package SFix renames Ada.Strings.Fixed;
+    package SMap renames Ada.Strings.Maps;
+
+
+
+
     ------------------------
     --  Constants From C  --
     ------------------------
@@ -85,7 +96,7 @@ package body Libao is
 
 
     function ao_append_option
-           (Options : in out System.Address;
+           (Options : in out Storage.Integer_Address;
             Key     : in     Interfaces.C.char_array;
             Value   : in     Interfaces.C.char_array)
         return Interfaces.C.int;
@@ -98,34 +109,34 @@ package body Libao is
     pragma Import (C, ao_append_global_option, "ao_append_global_option");
 
     procedure ao_free_options
-           (Options : in System.Address);
+           (Options : in Storage.Integer_Address);
     pragma Import (C, ao_free_options, "ao_free_options");
 
     function ao_open_live
            (Driver_ID : in Interfaces.C.int;
-            Format    : in System.Address;
-            Options   : in System.Address)
-        return System.Address;
+            Format    : in Storage.Integer_Address;
+            Options   : in Storage.Integer_Address)
+        return Storage.Integer_Address;
     pragma Import (C, ao_open_live, "ao_open_live");
 
     function ao_open_file
            (Driver_ID : in Interfaces.C.int;
             Filename  : in Interfaces.C.char_array;
             Overwrite : in Interfaces.C.int;
-            Format    : in System.Address;
-            Options   : in System.Address)
-        return System.Address;
+            Format    : in Storage.Integer_Address;
+            Options   : in Storage.Integer_Address)
+        return Storage.Integer_Address;
     pragma Import (C, ao_open_file, "ao_open_file");
 
     function ao_play
-           (Output_Device : in System.Address;
-            Samples       : in System.Address;
+           (Output_Device : in Storage.Integer_Address;
+            Samples       : in Storage.Integer_Address;
             Num_Bytes     : in Interfaces.Unsigned_32)
         return Interfaces.C.int;
     pragma Import (C, ao_play, "ao_play");
 
     function ao_close
-           (Output_Device : in System.Address)
+           (Output_Device : in Storage.Integer_Address)
         return Interfaces.C.int;
     pragma Import (C, ao_close, "ao_close");
 
@@ -141,12 +152,12 @@ package body Libao is
 
     function ao_driver_info
            (Ident : in Interfaces.C.int)
-        return System.Address;
+        return Storage.Integer_Address;
     pragma Import (C, ao_driver_info, "ao_driver_info");
 
     function ao_driver_info_list
            (Count : out Interfaces.C.int)
-        return System.Address;
+        return Storage.Integer_Address;
     pragma Import (C, ao_driver_info_list, "ao_driver_info_list");
 
     function ao_file_extension
@@ -161,57 +172,57 @@ package body Libao is
 
 
     function info_item_get
-           (Infos : in System.Address;
+           (Infos : in Storage.Integer_Address;
             Index : in Interfaces.C.int)
-        return System.Address;
+        return Storage.Integer_Address;
     pragma Import (C, info_item_get, "info_item_get");
     pragma Inline (info_item_get);
 
 
     function info_kind_get
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.int;
     pragma Import (C, info_kind_get, "info_kind_get");
     pragma Inline (info_kind_get);
 
     function info_name_get
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.Strings.chars_ptr;
     pragma Import (C, info_name_get, "info_name_get");
     pragma Inline (info_name_get);
 
     function info_short_name_get
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.Strings.chars_ptr;
     pragma Import (C, info_short_name_get, "info_short_name_get");
     pragma Inline (info_short_name_get);
 
     function info_preferred_byte_format_get
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.int;
     pragma Import (C, info_preferred_byte_format_get, "info_preferred_byte_format_get");
     pragma Inline (info_preferred_byte_format_get);
 
     function info_priority_get
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.int;
     pragma Import (C, info_priority_get, "info_priority_get");
     pragma Inline (info_priority_get);
 
     function info_comment_get
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.Strings.chars_ptr;
     pragma Import (C, info_comment_get, "info_comment_get");
     pragma Inline (info_comment_get);
 
     function info_option_count_get
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.int;
     pragma Import (C, info_option_count_get, "info_option_count_get");
     pragma Inline (info_option_count_get);
 
     function info_option_key_get
-           (Item  : in System.Address;
+           (Item  : in Storage.Integer_Address;
             Index : in Interfaces.C.int)
         return Interfaces.C.Strings.chars_ptr;
     pragma Import (C, info_option_key_get, "info_option_key_get");
@@ -225,20 +236,20 @@ package body Libao is
 
 
     function option_key
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.Strings.chars_ptr;
     pragma Import (C, option_key, "option_key");
     pragma Inline (option_key);
 
     function option_value
-           (Item : in System.Address)
+           (Item : in Storage.Integer_Address)
         return Interfaces.C.Strings.chars_ptr;
     pragma Import (C, option_value, "option_value");
     pragma Inline (option_value);
 
     function option_next
-           (Item : in System.Address)
-        return System.Address;
+           (Item : in Storage.Integer_Address)
+        return Storage.Integer_Address;
     pragma Import (C, option_next, "option_next");
     pragma Inline (option_next);
 
@@ -250,22 +261,29 @@ package body Libao is
     ------------------------
 
     procedure Do_Append
-           (Ptr   : in out System.Address;
-            Key   : in     Interfaces.C.char_array;
-            Value : in     Interfaces.C.char_array)
+           (Ptr_List : in out Address_Vectors.Vector;
+            Key      : in     Interfaces.C.char_array;
+            Value    : in     Interfaces.C.char_array)
     is
         Result : Interfaces.C.int;
+        Head   : Storage.Integer_Address := Head_Pointer (Ptr_List);
     begin
-        Result := ao_append_option (Ptr, Key, Value);
+        Result := ao_append_option (Head, Key, Value);
         if Result = 0 then
             raise Storage_Error;
         elsif Result /= 1 then
             raise Program_Error;
+        else
+            if Ptr_List.Length = 0 then
+                Ptr_List.Append (Head);
+            else
+                Ptr_List.Append (option_next (Ptr_List.Last_Element));
+            end if;
         end if;
     end Do_Append;
 
     procedure Do_Close
-           (Ptr : in System.Address)
+           (Ptr : in Storage.Integer_Address)
     is
         Result : Interfaces.C.int := ao_close (Ptr);
     begin
@@ -276,6 +294,17 @@ package body Libao is
         end if;
     end Do_Close;
 
+    function Head_Pointer
+           (This : in Address_Vectors.Vector)
+        return Storage.Integer_Address is
+    begin
+        if This.Length = 0 then
+            return Null_Pointer;
+        else
+            return This.First_Element;
+        end if;
+    end Head_Pointer;
+
 
 
 
@@ -286,14 +315,14 @@ package body Libao is
     procedure Adjust
            (This : in out Option_List)
     is
-        Old : System.Address := This.Ptr;
+        Old : Storage.Integer_Address := Head_Pointer (This.Ptr_List);
     begin
-        This.Ptr := System.Null_Address;
-        while Old /= System.Null_Address loop
+        This.Ptr_List := Address_Vectors.Empty_Vector;
+        while Old /= Null_Pointer loop
             Do_Append
-               (This.Ptr,
-                Interfaces.C.Strings.Value (option_key (This.Ptr)),
-                Interfaces.C.Strings.Value (option_value (This.Ptr)));
+               (This.Ptr_List,
+                Interfaces.C.Strings.Value (option_key (Old)),
+                Interfaces.C.Strings.Value (option_value (Old)));
             Old := option_next (Old);
         end loop;
     end Adjust;
@@ -301,7 +330,7 @@ package body Libao is
     procedure Finalize
            (This : in out Option_List) is
     begin
-        ao_free_options (This.Ptr);
+        ao_free_options (Head_Pointer (This.Ptr_List));
     end Finalize;
 
     procedure Adjust
@@ -381,9 +410,9 @@ package body Libao is
 
     function Priority_Level
            (Attributes : in Info)
-        return Positive is
+        return Natural is
     begin
-        return Positive (info_priority_get (Attributes.Ptr));
+        return Natural (info_priority_get (Attributes.Ptr));
     end Priority_Level;
 
     function Comment
@@ -406,10 +435,34 @@ package body Libao is
         return String is
     begin
         return Interfaces.C.Strings.Value
-            (info_option_key_get (Attributes.Ptr, Interfaces.C.int (Index)));
+            (info_option_key_get (Attributes.Ptr, Interfaces.C.int (Index) - 1));
     end Option_Key;
 
 
+    function Length
+           (Options : in Option_List)
+        return Natural is
+    begin
+        return Natural (Options.Ptr_List.Length);
+    end Length;
+
+    function Key
+           (Options : in Option_List;
+            Index   : in Positive)
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (option_key (Options.Ptr_List.Element (Index)));
+    end Key;
+
+    function Value
+           (Options : in Option_List;
+            Index   : in Positive)
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (option_value (Options.Ptr_List.Element (Index)));
+    end Value;
+
+
     function Image_Length
            (Channel : in Channel_Mnemonic)
         return Positive is
@@ -428,6 +481,7 @@ package body Libao is
            (Channel_Matrix : in Mnemonic_Array)
         return Natural
     is
+        --  Start by counting all the commas
         Result : Integer := Channel_Matrix'Length - 1;
     begin
         if Channel_Matrix'Length = 0 then
@@ -443,13 +497,14 @@ package body Libao is
            (Channel_Matrix : in Mnemonic_Array)
         return String
     is
-        Result : String (1 .. Image_Length (Channel_Matrix));
-        Position : Integer := 1;
+        Result    : String (1 .. Image_Length (Channel_Matrix));
+        Position  : Integer := 1;
+        Token_End : Positive;
     begin
         for Index in Integer range Channel_Matrix'First .. Channel_Matrix'Last - 1 loop
-            Result (Position .. Position + Image_Length (Channel_Matrix (Index))) :=
-                Channel_Matrix (Index)'Image & ",";
-            Position := Position + Image_Length (Channel_Matrix (Index)) + 1;
+            Token_End := Position + Image_Length (Channel_Matrix (Index));
+            Result (Position .. Token_End) := Channel_Matrix (Index)'Image & ",";
+            Position := Token_End + 1;
         end loop;
         Result (Position .. Result'Last) := Channel_Matrix (Channel_Matrix'Last)'Image;
         return Result;
@@ -473,6 +528,71 @@ package body Libao is
                 Matrix      => Interfaces.C.Strings.New_String (Image (Channel_Matrix))));
     end Create;
 
+    function Bits
+           (Format : in Sample_Format)
+        return Positive is
+    begin
+        return Positive (Format.C_Struct.Bits);
+    end Bits;
+
+    function Rate
+           (Format : in Sample_Format)
+        return Positive is
+    begin
+        return Positive (Format.C_Struct.Rate);
+    end Rate;
+
+    function Channels
+           (Format : in Sample_Format)
+        return Positive is
+    begin
+        return Positive (Format.C_Struct.Channels);
+    end Channels;
+
+    function Byte_Format
+           (Format : in Sample_Format)
+        return Endianness is
+    begin
+        if Format.C_Struct.Byte_Format = sample_little_endian then
+            return Little_Endian;
+        elsif Format.C_Struct.Byte_Format = sample_big_endian then
+            return Big_Endian;
+        elsif Format.C_Struct.Byte_Format = sample_native_endian then
+            return Machine_Native;
+        else
+            raise Constraint_Error;
+        end if;
+    end Byte_Format;
+
+    function Channel_Matrix
+           (Format : in Sample_Format)
+        return Mnemonic_Array
+    is
+        Input  : String := Interfaces.C.Strings.Value (Format.C_Struct.Matrix);
+        Result : Mnemonic_Array (1 .. SFix.Count (Input, SMap.To_Set (',')) + 1);
+        First  : Positive := 1;
+        Last   : Natural;
+        Place  : Positive := 1;
+    begin
+        if Input'Length = 0 then
+            return Empty : Mnemonic_Array (1 .. 0);
+        end if;
+        while First <= Input'Last loop
+            SFix.Find_Token
+               (Source => Input,
+                Set    => SMap.To_Set (','),
+                From   => First,
+                Test   => Str.Outside,
+                First  => First,
+                Last   => Last);
+            exit when Last = 0;
+            Result (Place) := Channel_Mnemonic'Value (Input (First .. Last));
+            Place := Place + 1;
+            First := Last + 1;
+        end loop;
+        return Result;
+    end Channel_Matrix;
+
 
 
 
@@ -485,7 +605,7 @@ package body Libao is
             Key   : in     String;
             Value : in     String) is
     begin
-        Do_Append (This.Ptr, Interfaces.C.To_C (Key), Interfaces.C.To_C (Value));
+        Do_Append (This.Ptr_List, Interfaces.C.To_C (Key), Interfaces.C.To_C (Value));
     end Append;
 
     procedure Append_Global_Option
@@ -510,13 +630,13 @@ package body Libao is
             Format    : in     Sample_Format'Class;
             Options   : in     Option_List'Class)
     is
-        Result : System.Address := ao_open_live
+        Result : Storage.Integer_Address := ao_open_live
            (Driver_ID => Interfaces.C.int (Driver_ID),
-            Format    => Format.C_Struct'Address,
-            Options   => Options.Ptr);
+            Format    => Storage.To_Integer (Format.C_Struct'Address),
+            Options   => Head_Pointer (Options.Ptr_List));
         My_Errno : Interfaces.C.int;
     begin
-        if Result = System.Null_Address then
+        if Result = Null_Pointer then
             My_Errno := get_errno;
             if My_Errno = error_no_driver then
                 raise No_Driver_Error;
@@ -548,15 +668,15 @@ package body Libao is
             Options   : in     Option_List'Class;
             Overwrite : in     Boolean := False)
     is
-        Result : System.Address := ao_open_file
+        Result : Storage.Integer_Address := ao_open_file
            (Driver_ID => Interfaces.C.int (Driver_ID),
             Filename  => Interfaces.C.To_C (Filename),
             Overwrite => Boolean'Pos (Overwrite),
-            Format    => Format.C_Struct'Address,
-            Options   => Options.Ptr);
+            Format    => Storage.To_Integer (Format.C_Struct'Address),
+            Options   => Head_Pointer (Options.Ptr_List));
         My_Errno : Interfaces.C.int;
     begin
-        if Result = System.Null_Address then
+        if Result = Null_Pointer then
             My_Errno := get_errno;
             if My_Errno = error_no_driver then
                 raise No_Driver_Error;
@@ -588,8 +708,7 @@ package body Libao is
     is
         Result : Interfaces.C.int := ao_play
            (Output_Device => Output.Ptr,
-            Samples       => Samples'Address,
-            --Samples       => Interfaces.C.To_C (Item => String (Samples), Append_Nul => False),
+            Samples       => Storage.To_Integer (Samples'Address),
             Num_Bytes     => Interfaces.Unsigned_32 (Samples'Length));
     begin
         if Result = 0 then
@@ -611,7 +730,7 @@ package body Libao is
         if Found then
             Do_Close (Output.Ptr);
         end if;
-        Output.Ptr := System.Null_Address;
+        Output.Ptr := Null_Pointer;
     end Close;
 
 
@@ -654,10 +773,10 @@ package body Libao is
            (Ident : in Driver_ID_Number)
         return Info
     is
-        Result : System.Address;
+        Result : Storage.Integer_Address;
     begin
         Result := ao_driver_info (Interfaces.C.int (Ident));
-        if Result = System.Null_Address then
+        if Result = Null_Pointer then
             raise No_Driver_Error;
         else
             return (Ptr => Result);
@@ -668,12 +787,12 @@ package body Libao is
         return Info_Array
     is
         Count : Interfaces.C.int;
-        Carr  : System.Address;
+        Carr  : Storage.Integer_Address;
     begin
         Carr := ao_driver_info_list (Count);
         return Actual : Info_Array (1 .. Positive (Count)) do
             for N in Integer range Actual'First .. Actual'Last loop
-                Actual (N) := (Ptr => info_item_get (Carr, Interfaces.C.int (N)));
+                Actual (N) := (Ptr => info_item_get (Carr, Interfaces.C.int (N - 1)));
             end loop;
         end return;
     end Driver_Info_List;
diff --git a/src/libao.ads b/src/libao.ads
index db5f7ce..c2013c5 100644
--- a/src/libao.ads
+++ b/src/libao.ads
@@ -16,7 +16,7 @@ private with
     Ada.Finalization,
     Ada.Containers.Vectors,
     Interfaces.C.Strings,
-    System;
+    System.Storage_Elements;
 
 
 package Libao is
@@ -58,7 +58,7 @@ package Libao is
 
     function Priority_Level
            (Attributes : in Info)
-        return Positive;
+        return Natural;
 
     function Comment
            (Attributes : in Info)
@@ -78,19 +78,54 @@ package Libao is
 
     Empty_Options : constant Option_List;
 
+    function Length
+           (Options : in Option_List)
+        return Natural;
+
+    function Key
+           (Options : in Option_List;
+            Index   : in Positive)
+        return String;
+
+    function Value
+           (Options : in Option_List;
+            Index   : in Positive)
+        return String;
+
 
     type Sample_Format is tagged private;
     type Channel_Mnemonic is (L, R, C, M, CL, CR, BL, BR, BC, SL, SR, LFE, A1, A2, A3, A4, X);
     type Mnemonic_Array is array (Positive range <>) of Channel_Mnemonic;
 
+    Stereo       : constant Mnemonic_Array := (L, R);
+    Quadraphonic : constant Mnemonic_Array := (L, R, BL, BR);
+
     function Create
            (Bits, Rate, Channels : in Positive;
             Byte_Format          : in Endianness;
             Channel_Matrix       : in Mnemonic_Array)
-        return Sample_Format;
+        return Sample_Format
+    with Pre => Channel_Matrix'Length = Channels;
 
-    Stereo       : constant Mnemonic_Array := (L, R);
-    Quadraphonic : constant Mnemonic_Array := (L, R, BL, BR);
+    function Bits
+           (Format : in Sample_Format)
+        return Positive;
+
+    function Rate
+           (Format : in Sample_Format)
+        return Positive;
+
+    function Channels
+           (Format : in Sample_Format)
+        return Positive;
+
+    function Byte_Format
+           (Format : in Sample_Format)
+        return Endianness;
+
+    function Channel_Matrix
+           (Format : in Sample_Format)
+        return Mnemonic_Array;
 
 
 
@@ -211,33 +246,61 @@ package Libao is
 private
 
 
+    package Storage renames System.Storage_Elements;
+    use type Interfaces.C.size_t, Storage.Integer_Address;
+
+
+    Null_Pointer : constant Storage.Integer_Address := Storage.To_Integer (System.Null_Address);
+
+
     pragma Linker_Options ("-lao");
 
 
+    function c_pointer_size
+        return Interfaces.C.size_t;
+    pragma Import (C, c_pointer_size, "c_pointer_size");
+
+    --  If this fails then we are on an architecture that for whatever reason
+    --  has significant problems interfacing between C and Ada
+    pragma Assert
+       (c_pointer_size * Interfaces.C.CHAR_BIT = Storage.Integer_Address'Size,
+        "Size of C void pointers and size of Ada address values do not match");
+
+
     for Data_Buffer'Component_Size use Interfaces.C.CHAR_BIT;
 
 
+    package Address_Vectors is new Ada.Containers.Vectors
+       (Index_Type   => Positive,
+        Element_Type => Storage.Integer_Address,
+        "="          => Storage."=");
+
+
     procedure Do_Append
-           (Ptr   : in out System.Address;
-            Key   : in     Interfaces.C.char_array;
-            Value : in     Interfaces.C.char_array);
+           (Ptr_List : in out Address_Vectors.Vector;
+            Key      : in     Interfaces.C.char_array;
+            Value    : in     Interfaces.C.char_array);
 
     procedure Do_Close
-           (Ptr : in System.Address);
+           (Ptr : in Storage.Integer_Address);
+
+    function Head_Pointer
+           (This : in Address_Vectors.Vector)
+        return Storage.Integer_Address;
 
 
     type Device is tagged record
-        Ptr : System.Address := System.Null_Address;
+        Ptr : Storage.Integer_Address := Null_Pointer;
     end record;
 
 
     type Info is tagged record
-        Ptr : System.Address := System.Null_Address;
+        Ptr : Storage.Integer_Address := Null_Pointer;
     end record;
 
 
     type Option_List is new Ada.Finalization.Controlled with record
-        Ptr : System.Address := System.Null_Address;
+        Ptr_List : Address_Vectors.Vector := Address_Vectors.Empty_Vector;
     end record;
 
     overriding procedure Adjust
@@ -247,7 +310,7 @@ private
            (This : in out Option_List);
 
     Empty_Options : constant Option_List :=
-        (Ada.Finalization.Controlled with Ptr => System.Null_Address);
+        (Ada.Finalization.Controlled with Ptr_List => Address_Vectors.Empty_Vector);
 
 
     type C_Sample_Format is record
@@ -270,11 +333,6 @@ private
 
 
     --  Keep track of open devices
-    package Address_Vectors is new Ada.Containers.Vectors
-       (Index_Type   => Positive,
-        Element_Type => System.Address,
-        "="          => System."=");
-
     Device_List : Address_Vectors.Vector := Address_Vectors.Empty_Vector;