path: root/src/portaudio.adb

--  Programmed by Jedidiah Barber
--  Released into the public domain


pragma Ada_2012;


with

    Ada.Strings.Fixed,
    Interfaces.C.Strings,
    System.Address_To_Access_Conversions;

use type

    Interfaces.C.int,
    Interfaces.Unsigned_32;


package body Portaudio is


    ------------------------
    --  Constants From C  --
    ------------------------

    pa_not_initialized : constant Interfaces.C.int;
    pragma Import (C, pa_not_initialized, "pa_not_initialized");

    pa_unanticipated_host_error : constant Interfaces.C.int;
    pragma Import (C, pa_unanticipated_host_error, "pa_unanticipated_host_error");

    pa_invalid_channel_count : constant Interfaces.C.int;
    pragma Import (C, pa_invalid_channel_count, "pa_invalid_channel_count");

    pa_invalid_sample_rate : constant Interfaces.C.int;
    pragma Import (C, pa_invalid_sample_rate, "pa_invalid_sample_rate");

    pa_invalid_device : constant Interfaces.C.int;
    pragma Import (C, pa_invalid_device, "pa_invalid_device");

    pa_invalid_flag : constant Interfaces.C.int;
    pragma Import (C, pa_invalid_flag, "pa_invalid_flag");

    pa_sample_format_not_supported : constant Interfaces.C.int;
    pragma Import (C, pa_sample_format_not_supported, "pa_sample_format_not_supported");

    pa_bad_io_device_combination : constant Interfaces.C.int;
    pragma Import (C, pa_bad_io_device_combination, "pa_bad_io_device_combination");

    pa_insufficient_memory : constant Interfaces.C.int;
    pragma Import (C, pa_insufficient_memory, "pa_insufficient_memory");

    pa_buffer_too_big : constant Interfaces.C.int;
    pragma Import (C, pa_buffer_too_big, "pa_buffer_too_big");

    pa_buffer_too_small : constant Interfaces.C.int;
    pragma Import (C, pa_buffer_too_small, "pa_buffer_too_small");

    pa_null_callback : constant Interfaces.C.int;
    pragma Import (C, pa_null_callback, "pa_null_callback");

    pa_bad_stream_ptr : constant Interfaces.C.int;
    pragma Import (C, pa_bad_stream_ptr, "pa_bad_stream_ptr");

    pa_timed_out : constant Interfaces.C.int;
    pragma Import (C, pa_timed_out, "pa_timed_out");

    pa_internal_error : constant Interfaces.C.int;
    pragma Import (C, pa_internal_error, "pa_internal_error");

    pa_device_unavailable : constant Interfaces.C.int;
    pragma Import (C, pa_device_unavailable, "pa_device_unavailable");

    pa_incompatible_host_api_specific_stream_info : constant Interfaces.C.int;
    pragma Import (C, pa_incompatible_host_api_specific_stream_info,
        "pa_incompatible_host_api_specific_stream_info");

    pa_stream_is_stopped : constant Interfaces.C.int;
    pragma Import (C, pa_stream_is_stopped, "pa_stream_is_stopped");

    pa_stream_is_not_stopped : constant Interfaces.C.int;
    pragma Import (C, pa_stream_is_not_stopped, "pa_stream_is_not_stopped");

    pa_input_overflowed : constant Interfaces.C.int;
    pragma Import (C, pa_input_overflowed, "pa_input_overflowed");

    pa_output_underflowed : constant Interfaces.C.int;
    pragma Import (C, pa_output_underflowed, "pa_output_underflowed");

    pa_host_api_not_found : constant Interfaces.C.int;
    pragma Import (C, pa_host_api_not_found, "pa_host_api_not_found");

    pa_invalid_host_api : constant Interfaces.C.int;
    pragma Import (C, pa_invalid_host_api, "pa_invalid_host_api");

    pa_cannot_read_from_a_callback_stream : constant Interfaces.C.int;
    pragma Import (C, pa_cannot_read_from_a_callback_stream,
        "pa_cannot_read_from_a_callback_stream");

    pa_cannot_write_to_a_callback_stream : constant Interfaces.C.int;
    pragma Import (C, pa_cannot_write_to_a_callback_stream,
        "pa_cannot_write_to_a_callback_stream");

    pa_cannot_read_from_an_output_only_stream : constant Interfaces.C.int;
    pragma Import (C, pa_cannot_read_from_an_output_only_stream,
        "pa_cannot_read_from_an_output_only_stream");

    pa_cannot_write_to_an_input_only_stream : constant Interfaces.C.int;
    pragma Import (C, pa_cannot_write_to_an_input_only_stream,
         "pa_cannot_write_to_an_input_only_stream");

    pa_incompatible_stream_host_api : constant Interfaces.C.int;
    pragma Import (C, pa_incompatible_stream_host_api, "pa_incompatible_stream_host_api");

    pa_bad_buffer_ptr : constant Interfaces.C.int;
    pragma Import (C, pa_bad_buffer_ptr, "pa_bad_buffer_ptr");


    pa_in_development : constant Interfaces.C.int;
    pragma Import (C, pa_in_development, "pa_in_development");

    pa_direct_sound : constant Interfaces.C.int;
    pragma Import (C, pa_direct_sound, "pa_direct_sound");

    pa_mme : constant Interfaces.C.int;
    pragma Import (C, pa_mme, "pa_mme");

    pa_asio : constant Interfaces.C.int;
    pragma Import (C, pa_asio, "pa_asio");

    pa_sound_manager : constant Interfaces.C.int;
    pragma Import (C, pa_sound_manager, "pa_sound_manager");

    pa_core_audio : constant Interfaces.C.int;
    pragma Import (C, pa_core_audio, "pa_core_audio");

    pa_oss : constant Interfaces.C.int;
    pragma Import (C, pa_oss, "pa_oss");

    pa_alsa : constant Interfaces.C.int;
    pragma Import (C, pa_alsa, "pa_alsa");

    pa_al : constant Interfaces.C.int;
    pragma Import (C, pa_al, "pa_al");

    pa_beos : constant Interfaces.C.int;
    pragma Import (C, pa_beos, "pa_beos");

    pa_wdmks : constant Interfaces.C.int;
    pragma Import (C, pa_wdmks, "pa_wdmks");

    pa_jack : constant Interfaces.C.int;
    pragma Import (C, pa_jack, "pa_jack");

    pa_wasapi : constant Interfaces.C.int;
    pragma Import (C, pa_wasapi, "pa_wasapi");

    pa_audio_science_hpi : constant Interfaces.C.int;
    pragma Import (C, pa_audio_science_hpi, "pa_audio_science_hpi");

    pa_sndio : constant Interfaces.C.int;
    pragma Import (C, pa_sndio, "pa_sndio");




    ------------------------
    --  Functions From C  --
    ------------------------

    function pa_get_version
        return Interfaces.C.int;
    pragma Import (C, pa_get_version, "Pa_GetVersion");

    function pa_get_version_info
        return System.Address;
    pragma Import (C, pa_get_version_info, "Pa_GetVersionInfo");

    function pa_get_error_text
           (Code : in Interfaces.C.int)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, pa_get_error_text, "Pa_GetErrorText");

    function pa_initialize
           (Sup : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, pa_initialize, "apa_init");

    function pa_terminate
        return Interfaces.C.int;
    pragma Import (C, pa_terminate, "apa_term");

    function pa_get_last_host_error_info
        return System.Address;
    pragma Import (C, pa_get_last_host_error_info, "Pa_GetLastHostErrorInfo");




    ------------------------
    --  Internal Utility  --
    ------------------------

    procedure Raise_Error
           (Num : in Interfaces.C.int) is
    begin
        if Num = pa_not_initialized then
            raise Not_Initialized_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_unanticipated_host_error then
            declare
                Info : C_Host_Error_Info;
                for Info'Address use pa_get_last_host_error_info;
                pragma Import (Ada, Info);
            begin
                raise Unanticipated_Host_Error with
                    Host_API_Kind'Image (To_Hat_Kind (Info.My_Host_API_Type)) & " " &
                    Interfaces.C.Strings.Value (Info.My_Error_Text);
            end;
        elsif Num = pa_invalid_channel_count then
            raise Invalid_Channel_Count_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_invalid_sample_rate then
            raise Invalid_Sample_Rate_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_invalid_device then
            raise Invalid_Device_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_invalid_flag then
            raise Invalid_Flag_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_sample_format_not_supported then
            raise Sample_Format_Not_Supported_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_bad_io_device_combination then
            raise Bad_IO_Device_Combination_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_insufficient_memory then
            raise Storage_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_buffer_too_big then
            raise Buffer_Too_Big_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_buffer_too_small then
            raise Buffer_Too_Small_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_null_callback then
            raise Null_Callback_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_bad_stream_ptr then
            raise Bad_Stream_Pointer_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_timed_out then
            raise Timed_Out_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_internal_error then
            raise Internal_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_device_unavailable then
            raise Device_Unavailable_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_incompatible_host_api_specific_stream_info then
            raise Incompatible_Host_API_Specific_Stream_Info_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_stream_is_stopped then
            raise Stream_Is_Stopped_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_stream_is_not_stopped then
            raise Stream_Is_Not_Stopped_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_input_overflowed then
            raise Input_Overflowed_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_output_underflowed then
            raise Output_Underflowed_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_host_api_not_found then
            raise Host_API_Not_Found_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_invalid_host_api then
            raise Invalid_Host_API_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_cannot_read_from_a_callback_stream then
            raise Can_Not_Read_From_A_Callback_Stream_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_cannot_write_to_a_callback_stream then
            raise Can_Not_Write_To_A_Callback_Stream_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_cannot_read_from_an_output_only_stream then
            raise Can_Not_Read_From_An_Output_Only_Stream_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_cannot_write_to_an_input_only_stream then
            raise Can_Not_Write_To_An_Input_Only_Stream_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_incompatible_stream_host_api then
            raise Incompatible_Stream_Host_API_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        elsif Num = pa_bad_buffer_ptr then
            raise Bad_Buffer_Pointer_Error with
                Interfaces.C.Strings.Value (pa_get_error_text (Num));
        else
            raise General_Failure;
        end if;
    end Raise_Error;

    function To_Hat_Kind
           (Num : in Interfaces.C.int)
        return Host_API_Kind is
    begin
        if Num = pa_in_development then
            return In_Development;
        elsif Num = pa_direct_sound then
            return Direct_Sound_Host;
        elsif Num = pa_mme then
            return MME_Host;
        elsif Num = pa_asio then
            return ASIO_Host;
        elsif Num = pa_sound_manager then
            return Sound_Manager_Host;
        elsif Num = pa_core_audio then
            return Core_Audio_Host;
        elsif Num = pa_oss then
            return OSS_Host;
        elsif Num = pa_alsa then
            return ALSA_Host;
        elsif Num = pa_al then
            return AL_Host;
        elsif Num = pa_beos then
            return BeOS_Host;
        elsif Num = pa_wdmks then
            return WDMKS_Host;
        elsif Num = pa_jack then
            return JACK_Host;
        elsif Num = pa_wasapi then
            return WASAPI_Host;
        elsif Num = pa_audio_science_hpi then
            return Audio_Science_HPI_Host;
        elsif Num = pa_sndio then
            return Sndio_Host;
        else
            raise Program_Error;
        end if;
    end To_Hat_Kind;

    function To_Cint
           (Ident : in Host_API_Kind)
        return Interfaces.C.int is
    begin
        case Ident is
            when In_Development         => return pa_in_development;
            when Direct_Sound_Host      => return pa_direct_sound;
            when MME_Host               => return pa_mme;
            when ASIO_Host              => return pa_asio;
            when Sound_Manager_Host     => return pa_sound_manager;
            when Core_Audio_Host        => return pa_core_audio;
            when OSS_Host               => return pa_oss;
            when ALSA_Host              => return pa_alsa;
            when AL_Host                => return pa_al;
            when BeOS_Host              => return pa_beos;
            when WDMKS_Host             => return pa_wdmks;
            when JACK_Host              => return pa_jack;
            when WASAPI_Host            => return pa_wasapi;
            when Audio_Science_HPI_Host => return pa_audio_science_hpi;
            when Sndio_Host             => return pa_sndio;
        end case;
    end To_Cint;




    -----------------------------------
    --  Controlled Type Subprograms  --
    -----------------------------------

    procedure Finalize
           (This : in out Final_Controller)
    is
        Code : Interfaces.C.int;
    begin
        Code := pa_terminate;
        if Code /= pa_no_error then
            Raise_Error (Code);
            raise Program_Error;
        end if;
    end Finalize;




    ---------------------------------
    --  Data Types and Structures  --
    ---------------------------------

    function "<"
           (A, B : in Version_Number)
        return Boolean is
    begin
        return (A.Major < B.Major) or else
            (A.Major = B.Major and A.Minor < B.Minor) or else
            (A.Major = B.Major and A.Minor = B.Minor and A.Subminor < B.Subminor);
    end "<";

    function Image
           (Num : in Version_Number)
        return String
    is
        function Img
               (Int : in Integer)
            return String is
        begin
            return Ada.Strings.Fixed.Trim (Integer'Image (Int), Ada.Strings.Both);
        end Img;
    begin
        return Img (Num.Major) & "." & Img (Num.Minor) & "." & Img (Num.Subminor);
    end Image;


    function Major
           (Version : in Version_Info)
        return Natural
    is
        Internal : C_Version_Info;
        for Internal'Address use Version.Ptr;
        pragma Import (Ada, Internal);
    begin
        return Natural (Internal.My_Major);
    end Major;

    function Minor
           (Version : in Version_Info)
        return Natural
    is
        Internal : C_Version_Info;
        for Internal'Address use Version.Ptr;
        pragma Import (Ada, Internal);
    begin
        return Natural (Internal.My_Minor);
    end Minor;

    function Subminor
           (Version : in Version_Info)
        return Natural
    is
        Internal : C_Version_Info;
        for Internal'Address use Version.Ptr;
        pragma Import (Ada, Internal);
    begin
        return Natural (Internal.My_Subminor);
    end Subminor;

    function Revision
           (Version : in Version_Info)
        return String
    is
        Internal : C_Version_Info;
        for Internal'Address use Version.Ptr;
        pragma Import (Ada, Internal);
    begin
        return Interfaces.C.Strings.Value (Internal.My_Revision);
    end Revision;

    function Text
           (Version : in Version_Info)
        return String
    is
        Internal : C_Version_Info;
        for Internal'Address use Version.Ptr;
        pragma Import (Ada, Internal);
    begin
        return Interfaces.C.Strings.Value (Internal.My_Text);
    end Text;


    function Image
           (Num : in Time)
        return String
    is
        Test_Out : String := Time'Image (Num);
        Mark_Start : Integer := Test_Out'First;
        Mark_End   : Integer := Test_Out'Last;
    begin
        if Test_Out (Mark_Start) = ' ' then
            Mark_Start := Mark_Start + 1;
        end if;
        while Test_Out (Mark_End) = '0' loop
            Mark_End := Mark_End - 1;
        end loop;
        if Test_Out (Mark_End) = '.' then
            Mark_End := Mark_End - 1;
        end if;
        return Test_Out (Mark_Start .. Mark_End);
    end Image;


    function Hertz_Image
           (Num : in Hertz)
        return String
    is
        type Large_Hack is delta 10.0**(-10) digits 30;
        Converted : Large_Hack := Large_Hack (Num);
        Prelim : String := Large_Hack'Image (Converted);
        Test_Out : String :=
           (if Prelim (Prelim'Last) /= '9' then Prelim
            elsif Prelim (Prelim'First) = '-' then Large_Hack'Image (Large_Hack'Pred (Converted))
            else Large_Hack'Image (Large_Hack'Succ (Converted)));
        Mark_Start : Integer := Test_Out'First + 1;
        Mark_End   : Integer := Test_Out'Last;
    begin
        while Test_Out (Mark_End) = '0' loop
            Mark_End := Mark_End - 1;
        end loop;
        if Test_Out (Mark_End) = '.' then
            Mark_End := Mark_End - 1;
        end if;
        return Test_Out (Mark_Start .. Mark_End);
    end Hertz_Image;


    function Load_Image
           (Num : in Load)
        return String
    is
        type Two_Digit_Hack is delta 10.0**(-2) digits 4;
        Test_Out : String := Two_Digit_Hack'Image (Two_Digit_Hack (Num));
        Mark_Start : Integer := Test_Out'First + 1;
        Mark_End   : Integer := Test_Out'Last;
    begin
        while Test_Out (Mark_End) = '0' loop
            Mark_End := Mark_End - 1;
        end loop;
        if Test_Out (Mark_End) = '.' then
            Mark_End := Mark_End - 1;
        end if;
        return Test_Out (Mark_Start .. Mark_End);
    end Load_Image;




    -----------------------
    --  API Subprograms  --
    -----------------------

    function Get_Version
        return Version_Number
    is
        Raw : Interfaces.Unsigned_32 := Interfaces.Unsigned_32 (pa_get_version);
        Result : Version_Number;
    begin
        Result.Major := Natural (Interfaces.Shift_Right (Raw, 16) and 16#FF#);
        Result.Minor := Natural (Interfaces.Shift_Right (Raw, 8) and 16#FF#);
        Result.Subminor := Natural (Raw and 16#FF#);
        return Result;
    end Get_Version;

    function Get_Version_Info
        return Version_Info is
    begin
        return (Ptr => pa_get_version_info);
    end Get_Version_Info;




begin

    declare
        Code : Interfaces.C.int;
    begin
        Code := pa_initialize (Boolean'Pos (True));
        if Code /= pa_no_error then
            Raise_Error (Code);
            raise Program_Error;
        end if;
    end;

end Portaudio;