-- Programmed by Jedidiah Barber -- Released into the public domain pragma Ada_2012; with Ada.Strings.Fixed, Interfaces.C.Strings; 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 Storage.Integer_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 Storage.Integer_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 Storage.To_Address (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 => Storage.To_Address (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;